home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / PROGTOOL / LIB211.ZIP;1 / DATES.PRG < prev    next >
Encoding:
Text File  |  1993-11-19  |  108.7 KB  |  2,596 lines
  1. *-----------------------------------------------------------------------
  2. *-- Program...: DATES.PRG
  3. *-- Date......: 08/09/1993
  4. *-- Notes.....: This program is the DATES program for the dUFLP library.
  5. *--             This version has been through some drastic changes,
  6. *--             as Jay Parsons overhauled a few routines, and added
  7. *--             a lot of new ones. See WHATS.NEW and README.TXT
  8. *--             for details.
  9. *-----------------------------------------------------------------------
  10.  
  11. FUNCTION DateText3
  12. *-----------------------------------------------------------------------
  13. *-- Programmer..: Miriam Liskin
  14. *-- Date........: 03/02/1992
  15. *-- Notes.......: Display date in format  Month, year
  16. *-- Written for.: dBASE IV, 1.1
  17. *-- Rev. History: 05/21/1991 - original function.
  18. *--               03/02/1992 - This one's Douglas P. Saine's (XRED)
  19. *--               invention.  In his words: "I just removed the middle
  20. *--               part looking for the day. For the things I do, I only
  21. *--               need the month and year. (I work for a defense
  22. *--               contractor, accuracy of dates has never been of great
  23. *--               concern. <G>)"
  24. *-- Calls.......: None
  25. *-- Called by...: Any
  26. *-- Usage.......: DateText3(<dDate>)
  27. *-- Example.....: ? DateText3(date())
  28. *-- Returns.....: July, 1991
  29. *-- Parameters..: dDate = date to be converted
  30. *-----------------------------------------------------------------------
  31.  
  32.    parameters dDate
  33.    
  34. RETURN cmonth(dDate)+", "+str(year(dDate),4)
  35. *-- EoF: DateText3()
  36.  
  37. FUNCTION Age2
  38. *-----------------------------------------------------------------------
  39. *-- Programmer..: Kenneth Chan [HazMatZak] (CIS: 72662,1305)
  40. *-- Date........: 07/01/1993
  41. *-- Notes.......: Returns number of full years between two dates, which
  42. *--               is the age of a person born on the first date as of
  43. *--               the second.
  44. *--               Returns 0 if second date is less than a year after
  45. *--               first date, -1 if second date is before first date by
  46. *--               one year or less, and so forth.  Does not check for
  47. *--               blank dates.
  48. *-- Written for.: dBASE IV, 1.1 and above
  49. *-- Rev. History: 10/23/1991 - Martin Leon ( HMAN ) - original function
  50. *--               04/22/1992 - Jay Parsons - description modified and
  51. *--               parameters changed
  52. *--               06/20/1993 - HazMatZak - replaced, better algorithm
  53. *--               07/01/1993 - Jay Parsons - changed to use floor()
  54. *--               instead of int() for coordination with WorkDays()
  55. *-- Calls.......: None
  56. *-- Called by...: Any
  57. *-- Usage.......: Age2(<d1>,<d2>)
  58. *-- Example.....: ? "A person born "+dtoc( d1 )+" was " ;
  59.                     + dtoc( Age2( d1, d2 ) ) +" years old on " ;
  60.                     + dtoc( d2 )+"."
  61. *-- Returns.....: Numeric value in years
  62. *-- Parameters..: d1 = first date, such as date of birth
  63. *--               d2 = second date, when age is wanted
  64. *-----------------------------------------------------------------------
  65.  
  66.    parameters dDate1, dDate2
  67.  
  68. RETURN floor( ( val( dtos( dDate2 ) ) - val( dtos( dDate1 ) ) ) ;
  69.               / 10000 )
  70. *-- EoF: Age2()
  71.  
  72. FUNCTION DoY
  73. *-----------------------------------------------------------------------
  74. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  75. *-- Date........: 07/07/1993
  76. *-- Notes.......: Returns the day of the year of a date (from beginning
  77. *--               of the year).  Known as "Julian" date in government
  78. *--               and military contexts.
  79. *-- Written for.: dBASE IV, 1.1
  80. *-- Rev. History: 11/10/1991 - original function.
  81. *--               11/14/1991 - Ken Mayer - expanded for readability ...
  82. *--               07/07/1993 - Jay Parsons - revised to use Zak's FDoY()
  83. *-- Calls.......: FDoY()                        FUNCTION in Dates.prg
  84. *-- Called by...: Any
  85. *-- Usage.......: DoY(<dDate>)
  86. *-- Example.....: ?DoY({01/01/91})
  87. *-- Returns.....: Numeric value of day of year
  88. *-- Parameters..: dDate  = Date being tested for ...
  89. *-----------------------------------------------------------------------
  90.  
  91.    parameters dDate
  92.  
  93. RETURN dDate - FDoY( dDate ) + 1
  94. *-- EoF: DoY()
  95.  
  96. FUNCTION Annivrsry
  97. *-----------------------------------------------------------------------
  98. *-- Programmer..: David Love (CIS: 70153,2433) and Jay Parsons
  99. *--               (CIS: 72662,1302)
  100. *-- Date........: 11/10/1991
  101. *-- Notes.......: Checks to see if an anniversary date falls within a
  102. *--               range of dates (handy for mailings for organizations,
  103. *--               checking to see if someone's birthday falls within
  104. *--               certain dates, etc.
  105. *-- Written for.: dBASE IV, 1.1
  106. *-- Rev. History: 11/10/1991 - Original Release
  107. *--               06/30/1992 - Jay Parsons - revised to work with Zak's
  108. *--               Age2(), ages less than one year
  109. *-- Calls.......: Age2()                        FUNCTION in DATES.PRG
  110. *-- Called by...: Any
  111. *-- Usage.......: Annivrsry(<dTest>,<dBegin>,<dEnd>)
  112. *-- Example.....: if Annivrsry(dBDay,{03/01/91},{03/31/91})
  113. *--                  *-- do something
  114. *--               endif
  115. *-- Returns.....: .T. if a date (dTest), or its anniversary, falls
  116. *--               within the period beginning at dBegin or ending at
  117. *--               dEnd, inclusive.  Returns .F. for any other
  118. *--               result, including invalid ranges or blank dates.
  119. *-- Parameters..: dTest  = Date being tested for ...
  120. *--               dBegin = Beginning of range
  121. *--               dEnd   = End of range
  122. *-----------------------------------------------------------------------
  123.  
  124.    parameters dTest, dBegin, dEnd
  125.    private nYears
  126.  
  127.    m->nYears = 0
  128.    * This "if" test will fail if a date is blank
  129.    if dBegin <= dEnd .AND. dTest <= dEnd
  130.       m->nYears = age2( dTest, dEnd ) - age2( dTest, dBegin - 1 )
  131.    endif
  132.  
  133. RETURN m->nYears # 0
  134. *-- EoF: Annivrsry()
  135.  
  136. FUNCTION AddMonths
  137. *-----------------------------------------------------------------------
  138. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  139. *-- Date........: 06/07/1993
  140. *-- Notes.......: Finds same day as given date N months ahead.
  141. *--               This function will return the first day of the
  142. *--               following month if there is no equal date in the month
  143. *--               otherwise returned and nMonths is positive, or the
  144. *--               last day of the month if nMonths is negative.  That
  145. *--               is, a call with {01/31/91} (January 31, 1991) and 1
  146. *--               would yield March 1, there being no February 31.
  147. *--               Do not use this function successively to find first
  148. *--               the date one month ahead, then the date one month
  149. *--               beyond that.  Instead, to find the date two months
  150. *--               ahead from the original date, call this function with
  151. *--               the original date and nMonths = 2.  Otherwise, in the
  152. *--               example, you'll get April 1 the second time rather
  153. *--               than the correct March 31.
  154. *-- Written for.: dBASE IV, 1.1
  155. *-- Rev. History: 11/10/1991 -- Original Release
  156. *--               06/07/1993 -- Lee Hite (CIS: 71213,2475).  added ROUND
  157. *--               function in new date computation to prevent decimals
  158. *--               being returned in the date value.  This insures that
  159. *--               dBase relational operators will work correctly with
  160. *--               the result, i.e., AddMonths({1/1/91},1)={2/1/91} will
  161. *--               return true, whereas before it would not, even though
  162. *--               the calculated date appeared correct when evaluated
  163. *--               as a character string.
  164. *-- Calls.......: None
  165. *-- Called by...: Any
  166. *-- Usage.......: AddMonths(<dDate>,<nMonths>)
  167. *-- Example.....: ?AddMonths({01/01/91},1)
  168. *-- Returns.....: Date
  169. *-- Parameters..: dDate   = Date being tested for ...
  170. *--               dMonths = Number of months "ahead"
  171. *-----------------------------------------------------------------------
  172.  
  173.    parameters dDate, nMonths
  174.    private dNew, dTest,dReturn
  175.  
  176.    m->dNew = dDate - day( dDate )+ 15 ;
  177.              + round( 30.436875 * nMonths, 0 ) &&middle of month
  178.    m->dTest = m->dNew - day( m->dNew ) + day( dDate )
  179.    m->dReturn = iif( month( m->dTest ) = month( m->dNew ), ;
  180.                 m->dTest, m->dTest - day( m->dTest ) ;
  181.                 + iif( nMonths > 0, 1, 0 ) )
  182.  
  183. RETURN dReturn
  184. *-- EoF: AddMonths()
  185.  
  186. FUNCTION AddYears
  187. *-----------------------------------------------------------------------
  188. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  189. *-- Date........: 11/14/1991
  190. *-- Notes.......: Finds same day as given date N years ahead. 
  191. *--               Using this function dBASE IV will take care of
  192. *--               converting February 29 to March 1 if moving from a
  193. *--               leap to a non-leap year.  However, it may not be used
  194. *--               backwards (negative value of nYears) since the date a
  195. *--               year before February 29, 1992 will be returned as
  196. *--               March 1, 1991, not February 28, 1991.  If you must
  197. *--               move back, either check explicitly for February 29
  198. *--               as the original date or add code as in the AddMonths()
  199. *--               function to test for the date returned being of a
  200. *--               different month than the original and, if it is, to
  201. *--               subtract its day().
  202. *-- Written for.: dBASE IV, 1.1
  203. *-- Rev. History: 11/10/1991 - original function.
  204. *--               11/14/1991 - Ken Mayer - expanded out to make it
  205. *--               easier to read, and see what's happening.
  206. *-- Calls.......: None
  207. *-- Called by...: Any
  208. *-- Usage.......: AddYears(<dDate>,<nYears>)
  209. *-- Example.....: ?AddYears({01/01/91},1)
  210. *-- Returns.....: Date
  211. *-- Parameters..: dDate  = Date being tested for ...
  212. *--               dYears = Number of Years "ahead"
  213. *-----------------------------------------------------------------------
  214.    
  215.    parameters dDate, nYears
  216.    private cYear,cMonth,cDay,dReturn
  217.    
  218.    m->cYear = str( year( dDate ) + nYears )
  219.    m->cMonth = right( str( month( dDate ) + 100 ), 2 )
  220.    m->cDay = right( str( day( dDate ) + 100 ), 2 )
  221.    m->dReturn = ctod( m->cMonth + "/" + m->cDay + "/" + m->cYear )
  222.       
  223. RETURN m->dReturn
  224. *-- EoF: AddYears()
  225.  
  226. FUNCTION WeekNo
  227. *-----------------------------------------------------------------------
  228. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  229. *-- Date........: 08/02/1993
  230. *-- Notes.......: Returns the week number of the year of a date (from
  231. *--               beginning of the year).  Week 1 is considered to start
  232. *--               with the first Sunday of the year.  Dates before the
  233. *--               first Sunday will be returned as week 0 and dates
  234. *--               on or after the 53rd Sunday as week 53.  To change
  235. *--               this behavior, use max() with 52, or min() with 1, on
  236. *--               the value returned.
  237. *--               To use this function but start the week on a different
  238. *--               day, change the 1 in the second-to-last code line, the
  239. *--               dow() of Sunday, to the dow() of the day that should
  240. *--               start each week, 2 for Monday through 7 for Saturday.
  241. *-- Written for.: dBASE IV, 1.1
  242. *-- Rev. History: 11/10/1991 - original function.
  243. *--               11/14/1991 - Ken Mayer - expanded for readability ...
  244. *--               08/02/1993 - Jay Parsons - revised to use FDoY().
  245. *-- Calls.......: FDoY()               Function in DATES.PRG
  246. *-- Called by...: Any
  247. *-- Usage.......: WeekNo(<dDate>)
  248. *-- Example.....: ?WeekNo({01/01/91})
  249. *-- Returns.....: Numeric value of week number
  250. *-- Parameters..: dDate  = Date being tested for ...
  251. *-----------------------------------------------------------------------
  252.    
  253.    parameters dDate
  254.    private dBaseDate,nReturn
  255.    
  256.    m->dBaseDate = FDoY( dDate ) - 1
  257.    m->dBaseDate = m->dBaseDate - mod( dow( m->dBaseDate - 1 ), 7 )
  258.    *  change this value to dow() of day starting week  ---^
  259.    m->nReturn = int( ( dDate - m->dBaseDate ) / 7 )
  260.  
  261. RETURN m->nReturn
  262. *-- EoF: WeekNo()
  263.  
  264. FUNCTION EasterDay
  265. *-----------------------------------------------------------------------
  266. *-- Programmer..: Jay Parsons (USSBBS, CIS 72662,1302)
  267. *-- Date........: 08/02/1993
  268. *-- Notes.......: Returns date of Easter for given year after 1582.
  269. *--               This gives the date of Easter as celebrated by Western
  270. *--               churches.  The algorithm is from Example 1.3.2.14 of
  271. *--               Volume I of "The Art of Computer Programming", 2nd
  272. *--               Edition, Addison-Wesley, Reading, MA, 1973, by Donald
  273. *--               Knuth, who attributes it to Aloysius Lilius of Naples
  274. *--               and Christopher Clavius of Germany, both floruit 1582.
  275. *-- Written for.: dBASE IV, 1.1
  276. *-- Rev. History: 11/18/1991 - original function.
  277. *--               04/22/1992 - Jay Parsons - Notes expanded.
  278. *--               11/20/1992 - David Love -  Added the private variable
  279. *--               lYear.
  280. *--               12/03/1992 - Jay Parsons - renamed lYear and dPascMoon
  281. *--               08/02/1993 - Jay Parsons - changed iif to if/endif
  282. *-- Calls.......: None
  283. *-- Called by...: Any
  284. *-- Usage.......: EasterDay(<Year>)
  285. *-- Example.....: EasterDay(91)
  286. *-- Returns.....: Date (in dBASE date format) of Easter
  287. *-- Parameters..: nYear  =  Numeric form of year - YYYY or YY format
  288. *-----------------------------------------------------------------------
  289.     
  290.    parameters nYear
  291.    private nYr, nGolden, nCentury, nNoLeap
  292.    private nMoonOrbit, nEPact, dPascMoon, dReturn
  293.     
  294.    *-- deal with two digit year ...
  295.    m->nYr = nYear
  296.    if m->nYr < 100
  297.       m->nYr = m->nYr + 100 * int( year( date() ) / 100 )
  298.    endif
  299.     
  300.    m->nGolden    = 1 + mod( m->nYr, 19 )
  301.    m->nCentury   = floor( m->nYr / 100 ) + 1
  302.    m->nNoLeap    = floor( 3 * m->nCentury / 4 ) - 12
  303.    m->nMoonOrbit = floor( ( 8 * m->nCentury + 5 ) / 25 ) - 5
  304.    m->nEPact     = mod( 11 * m->nGolden + m->nMoonOrbit - m->nNoLeap ;
  305.                          + 20, 30 )
  306.    if m->nEPact = 24 .or. ( m->nEPact = 25 .and. m->nGolden > 11 )
  307.       m->nEpact = m->nEpact + 1
  308.    endif
  309.    m->dPascMoon  = ctod( "03/21/" + str( m->nYr ) ) ;
  310.                    + mod( 53 - m->nEPact, 30 )
  311.    m->dReturn    = m->dPascMoon + 8 - dow( m->dPascMoon )
  312.  
  313. RETURN m->dReturn
  314. *-- EoF: EasterDay()
  315.  
  316. FUNCTION nDoW
  317. *-----------------------------------------------------------------------
  318. *-- Programmer..: Jay Parsons (CIS: 72662,1302) 
  319. *-- Date........: 04/22/1992
  320. *-- Notes.......: Numeric Day of Week -- returns the numeric dow value
  321. *--               of a named day of the week for use by some of the
  322. *--               other date functions herein.
  323. *-- Written for.: dBASE IV, 1.1
  324. *-- Rev. History: 02/25/1992 - original function.
  325. *--               04/22/1992 - Jay Parsons - modified example and
  326. *--               descriptions, added ltrim() of argument.
  327. *-- Calls.......: None
  328. *-- Called by...: None
  329. *-- Usage.......: nDoW(<cDay>)
  330. *-- Example.....: nDay = nDoW("Tues")
  331. *-- Returns.....: Numeric dow value of day of week given
  332. *-- Parameters..: cDay  -- Character memvar containing "day" of week
  333. *--                        ('MONDAY', etc ...)
  334. *-----------------------------------------------------------------------
  335.  
  336.    parameter cDay
  337.    
  338. RETURN at( upper( left( ltrim( cDay ), 3 ) ), ;
  339.           "   SUN MON TUE WED THU FRI SAT" ) / 4
  340. *-- nDoW()
  341.  
  342. FUNCTION FWDoM
  343. *-----------------------------------------------------------------------
  344. *-- Programmer..: Jay Parsons (CIS: 72662,1302) 
  345. *-- Date........: 02/25/1992
  346. *-- Notes.......: First Working Day of the Month -- originally I used
  347. *--               Dan Madoni's stuff from Technotes, but Jay came along
  348. *--               and pointed out an easier way to do this. SO, here we
  349. *--               have a shorter, faster, FWDoM function. This returns
  350. *--               the date of the first WORKING day ( day that is
  351. *--               neither Saturday nor Sunday ) of the month of the date
  352. *--               given as a parameter.
  353. *-- Written for.: dBASE IV, 1.1
  354. *-- Rev. History: 02/25/1992 - Original Release
  355. *-- Calls.......: None
  356. *-- Called by...: Any
  357. *-- Usage.......: FWDoM(<dDate>)
  358. *-- Example.....: ? CDoW( FWDoM(DATE()) ) (character day of week ...)
  359. *-- Returns.....: dBASE Date
  360. *-- Parameters..: dDate  -- date to work from ...
  361. *-----------------------------------------------------------------------
  362.  
  363.    parameters dDate
  364.    private dReturn, nDay
  365.    
  366.    m->dReturn = dDate - day( dDate ) + 1
  367.    m->nDay = dow( m->dReturn )
  368.    
  369. RETURN m->dReturn + iif( m->nDay = 7, 2, iif( m->nDay = 1, 1 ,0 ) )
  370. *-- EoF: FWDoM()
  371.  
  372. FUNCTION LWDoM
  373. *-----------------------------------------------------------------------
  374. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  375. *-- Date........: 02/25/1992
  376. *-- Notes.......: Last Working Day of the Month -- function from Jay
  377. *--               (new version like FWDoM) to return the last working
  378. *--               day of the month. Give a date, the function returns
  379. *--               the last WORKING day of the month. This has a
  380. *--               companion function, giving the FIRST working day
  381. *--               (see above).
  382. *-- Written for.: dBASE IV, 1.1
  383. *-- Rev. History: 02/25/1992 - Original Release
  384. *-- Calls.......: LDOM()               Function in DATES.PRG
  385. *-- Called by...: Any
  386. *-- Usage.......: LWDoM(<dDate>)
  387. *-- Example.....: ? LWDoM(DATE())
  388. *-- Returns.....: dBASE Date
  389. *-- Parameters..: dDate  -- date to work from ...
  390. *-----------------------------------------------------------------------
  391.  
  392.    parameters dDate
  393.    private dReturn, nDay
  394.    
  395.    m->dReturn = LDoM( dDate )
  396.    m->nDay = dow( m->dReturn )
  397.  
  398. RETURN m->dReturn - iif( m->nDay = 7, 1, iif( m->nDay = 1, 2, 0 ) )
  399. *-- EoF: LWDoM()
  400.  
  401. FUNCTION FDoD
  402. *-----------------------------------------------------------------------
  403. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  404. *-- Date........: 08/02/1993
  405. *-- Notes.......: First Day of Date. This function works to give the
  406. *--               date of the first occurrence in the month of the given
  407. *--               date of a given day of the week (i.e., first Monday of
  408. *--               the month).
  409. *--               It returns a blank date if the day of week is invalid,
  410. *--               but is not case sensitive. New, slimmer, sleeker
  411. *--               version by Jay ...
  412. *-- Written for.: dBASE IV, 1.1
  413. *-- Rev. History: 02/25/1992 - Original Release
  414. *--               08/02/1993 - Jay Parsons - revised to use FDoM().
  415. *-- Calls.......: NDOW()               Function in DATES.PRG
  416. *--               FDOM()               Function in DATES.PRG
  417. *-- Called by...: Any
  418. *-- Usage.......: FDoD(<dDate>,"<cDay>")
  419. *-- Example.....: ? FDoD(DATE(),"Tuesday")
  420. *-- Returns.....: dBASE Date
  421. *-- Parameters..: dDate  -- date to work from ...
  422. *--               cDay   -- Day of week to look for ...
  423. *-----------------------------------------------------------------------
  424.  
  425.    parameters dDate, cDay
  426.    private dReturn, nDay
  427.    
  428.    m->nDay = nDoW(cDay)
  429.    m->dReturn = FDoM( dDate )
  430.    
  431. RETURN m->dReturn + mod( m->nDay + 7 - dow( dReturn ), 7 )
  432. *-- EoF: FDoD()
  433.  
  434. FUNCTION LDoD
  435. *-----------------------------------------------------------------------
  436. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  437. *-- Date........: 08/02/1993
  438. *-- Notes.......: Last Day of Date. This function works to give the
  439. *--               date of the last occurrence in the month of the given
  440. *--               date of a given day of the week (i.e., last Monday of
  441. *--               the month).
  442. *--               It returns a blank date if the day of week is invalid,
  443. *--               but is not case sensitive. New version as FDoD() ...
  444. *-- Written for.: dBASE IV, 1.1
  445. *-- Rev. History: 02/25/1992 - Original Release
  446. *--               08/02/1993 - Jay Parsons - declared nDay private.
  447. *-- Calls.......: LDOM()               Function in DATES.PRG
  448. *--               NDOW()               Function in DATES.PRG
  449. *-- Called by...: Any
  450. *-- Usage.......: LDoD(<dDate>,"<cDay>")
  451. *-- Example.....: ? LDoD(DATE(),"Tuesday")
  452. *-- Returns.....: dBASE Date
  453. *-- Parameters..: dDate  -- date to work from ...
  454. *--               cDay   -- Day of week to look for ...
  455. *-----------------------------------------------------------------------
  456.  
  457.    parameters dDate, cDay
  458.    private dReturn, nDay
  459.    
  460.    m->nDay = nDoW( cDay )
  461.    m->dReturn = LDoM( dDate )
  462.    
  463. RETURN m->dReturn - mod( dow( m->dReturn ) + 7 - m->nDay, 7 )
  464. *-- EoF: LDoD()
  465.  
  466. FUNCTION LDoM
  467. *-----------------------------------------------------------------------
  468. *-- Programmer..: Ken Chan [HazMatZak] (CIS: 72662,1305)
  469. *-- Date........: 02/26/1992
  470. *-- Notes.......: Last Day of Month -- Zak wrote this one up as a MUCH
  471. *--               shorter and more straightforward version of one I did.
  472. *--               >sigh<.  This function returns the date of the last
  473. *-                day of the month.
  474. *-- Written for.: dBASE IV, 1.1
  475. *-- Rev. History: 02/26/1992 -- Original Release
  476. *-- Calls.......: None
  477. *-- Called by...: Any
  478. *-- Usage.......: LDoM(<dDate>)
  479. *-- Example.....: ? LDoM(DATE())
  480. *-- Returns.....: dBASE Date
  481. *-- Parameters..: dDate  -- date to work from ...
  482. *-----------------------------------------------------------------------
  483.  
  484.    parameter dDate
  485.    private dNxtMonth
  486.    
  487.    m->dNxtMonth = dDate - day( dDate ) + 45 && middle of next month
  488.    
  489. RETURN m->dNxtMonth - day( n->dNxtMonth )
  490. *-- EoF: LDoM()
  491.  
  492. FUNCTION NumDoD
  493. *-----------------------------------------------------------------------
  494. *-- Programmer..: Ken Mayer (CIS: 71333,1033)
  495. *-- Date........: 02/24/1992
  496. *-- Notes.......: This function will return the x daytype of a month.
  497. *--               Example: what if you need the third Monday of the
  498. *--               month?
  499. *-                Send to this function a date (any date) of the month,
  500. *--               the number you need (first, second...) and the day you
  501. *--               need. The function is not case specific.
  502. *-- Written for.: dBASE IV, 1.1
  503. *-- Rev. History: 02/24/1992 -- Original Release
  504. *-- Calls.......: FDOD()               Function in DATES.PRG
  505. *--               NDOW()               Function in DATES.PRG
  506. *-- Called by...: Any
  507. *-- Usage.......: NumDoD(<dDate>,<nDay>,<cDay>)
  508. *-- Example.....: ?NumDoD({02/03/92},3,"Monday")
  509. *-- Returns.....: Date
  510. *-- Parameters..: dDate  =  Any date of the month (and year) needed
  511. *--               nDay   =  Number of day you need (i.e., third cDay of
  512. *--                         the month
  513. *--               cDay   =  Character name of day ("Monday", etc.)
  514. *-----------------------------------------------------------------------
  515.  
  516.    parameter dDate, nDay, cDay
  517.    private dReturn
  518.    
  519.    m->dReturn = FDoD( dDate, cDay )  && get the first of this dow.
  520.    if nDay > 1                       && if a later one is wanted,
  521.                                      && add 7 days * required # ...
  522.       m->dReturn = m->dReturn + ( ( nDay - 1 ) * 7 )
  523.    endif
  524.    
  525. RETURN m->dReturn
  526. *-- EoF: NumDoD()
  527.  
  528. FUNCTION WDiF
  529. *-----------------------------------------------------------------------
  530. *-- Programmer..: Martin Leon (HMAN)
  531. *-- Date........: 12/12/1991
  532. *-- Notes.......: This UDF is designed to return the first Working Day
  533. *--               In the Future of a specific date, based on a # of
  534. *--               days. For example, to return the first working day, 10
  535. *--               working days from the current date, you can pass the
  536. *--               parameters of DATE() and 10. If the date 10 days from
  537. *--               today is a working day, that date is returned,
  538. *--               otherwise, the function returns the next succeeding
  539. *--               working day. You may, if you wish, use a database to
  540. *--               store holidays. If you do, the database must be laid
  541. *--               out with the following structure:
  542. *--                 HOLIDAYS.DBF
  543. *--                 Field name  Field type  MDX?
  544. *--                 HOLIDATE      Date       Y
  545. *--               Once the UDF has been run, the database is left open
  546. *--               in whatever work area it was opened.  If another
  547. *--               database was in use at the time of calling the UDF, it
  548. *--               becomes the active database after the UDF is done. The
  549. *--               reason for leaving the database open is that this
  550. *--               speeds up the process when you call on the UDF several
  551. *--               times in a row.
  552. *--               To ensure that holidays are working properly, there
  553. *--               are 3 assumptions made by this function, and all must
  554. *--               be true.  These are:
  555. *--                     1) WDIF() assumes that your holidays database
  556. *--                        has an index tag on the HOLIDATE field,
  557. *--                     2) there are no duplicate entries, and
  558. *--                     3) none of the holidays in the database falls
  559. *--                        on a weekend date. A simple method for
  560. *--                        insuring the last is:
  561. *--                 USE Holidays
  562. *--                 DELETE ALL FOR dow( Holidate ) = 7 ;
  563. *--                           .or. dow( Holidate ) = 1
  564. *--                 PACK
  565. *--               If you do not have a Holidays database, this function
  566. *--               will work fine ...
  567. *-- Written for.: dBASE IV, 1.1
  568. *-- Rev. History: 12/12/1991 -- Original Release
  569. *-- Calls.......: None
  570. *-- Called by...: Any
  571. *-- Usage.......: WDIF(<dStart>,<nDays>)
  572. *-- Example.....: ?WDiF(date(),10)
  573. *-- Returns.....: dBASE date
  574. *-- Parameters..: dStart  =  Date to start counting from
  575. *--               nDays   =  Number of working days in the future ...
  576. *-----------------------------------------------------------------------
  577.  
  578.    parameter dStart, nWDays
  579.    private nWeeks, nN, nXtraDays, nHDays
  580.    private dReturn, cNear, cAlias, dTemp
  581.    
  582.    store 0 to m->nWeeks, m->nN, m->nHDays, m->nXtraDays
  583.    store {} to m->dReturn, m->dTemp
  584.    store "" to m->cNear, m->cAlias
  585.    m->cNear = set("NEAR")
  586.    
  587.    if nWDays = 0
  588.       RETURN 0
  589.    endif
  590.    
  591.    if type("dStart") + type("nWDays") # "DN"
  592.       RETURN -1
  593.    endif
  594.    
  595.    *-- Rough guestimate of future date within a week
  596.    m->nWeeks = int( nWDays / 5 )
  597.    m->dReturn = dStart + ( m->nWeeks * 7 )
  598.    
  599.    *-- Left over number of days from integer division above
  600.    m->nXtraDays = mod( nWDays, 5 )
  601.    
  602.    *-- Check to see if Holidays database is already in use.  This
  603.    *-- is done so that we don't have to close and open the database
  604.    *-- for every call to this UDF. The first call opens it and
  605.    *-- subsequent calls select it as needed.
  606.    
  607.    *-- Check all work areas for holidays database, starting with
  608.    *-- work area 10 since this is most likely where it was opened
  609.    *-- the first time.
  610.    m->nN = 10
  611.    do while .not. "HOLIDAYS" $ alias( m->nN )
  612.       m->nN = m->nN - 1
  613.       if m->nN = 0
  614.          exit
  615.       endif
  616.    enddo
  617.    *-- If it is open, store current alias name and select holidays
  618.    *-- database.
  619.    if m->nN # 0
  620.       m->cAlias = alias()
  621.       select ( alias( m->nN ) )
  622.    else
  623.       *-- If it isn't the currently selected database,
  624.       *-- make sure it exists and use it and select it.
  625.       if file( "HOLIDAYS.DBF" )
  626.          cAlias = alias()
  627.          use Holidays order Holidate in select()
  628.          select Holidays
  629.       endif
  630.    endif
  631.    *-- If it's active now ...
  632.    if alias() = "HOLIDAYS"
  633.       *-- make sure it's in Holidate order, and ...
  634.       if order() # "HOLIDATE"
  635.          set order to Holidate
  636.       endif
  637.       set near on
  638.       *-- count all records in holiday database that fall within
  639.       *-- the range of the starting date and the rough guestimate
  640.       *-- date.
  641.       seek dStart
  642.       *-- don't count starting day if it's in Holidays database.
  643.       if dStart = Holidate
  644.          skip
  645.       endif
  646.       scan while m->dReturn >= Holidate
  647.            m->nHDays = m->nHDays + 1
  648.       endscan
  649.       set near off
  650.    endif
  651.    
  652.    *-- Add holidays to "left over" days from original guestimate
  653.    m->nXtraDays = m->nXtraDays + m->nHDays
  654.    
  655.    *-- Add extra days one day at a time to the guestimate,
  656.    *-- skipping over holidays and weekends.
  657.    
  658.    do while m->nXtraDays > 0
  659.       m->dReturn = m->dReturn + 1
  660.       if alias() = "HOLIDAYS"
  661.          if seek( m->dReturn )
  662.             loop
  663.          endif
  664.       endif
  665.       if dow( m->dReturn ) = 7 .or. dow( m->dReturn ) = 1
  666.          loop
  667.       endif
  668.       m->nXtraDays = m->nXtraDays - 1
  669.    enddo
  670.    
  671.    *-- If return date falls on Saturday or Sunday, "re-wind" to
  672.    *-- Friday.
  673.    m->dReturn = m->dReturn - iif( dow( m->dReturn ) = 7, 1, ;
  674.                 iif( dow( m->dReturn) = 1, 2, 0 ) )
  675.    
  676.    *-- If another database was origally in use, make it the active
  677.    *-- database again.
  678.    if "" # m->cAlias
  679.       select ( m->cAlias )
  680.    endif
  681.    *-- set NEAR back to what it was orginally.
  682.    set near &cNear.
  683.  
  684. RETURN m->dReturn
  685. *-- EoF: WDiF()
  686.  
  687. FUNCTION StoD
  688. *-----------------------------------------------------------------------
  689. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  690. *-- Date........: 08/02/1993
  691. *-- Notes.......: Convert string YYYYMMDD or YYMMDD to a date regardless
  692. *--               of SET DATE.
  693. *-- Written for.: dBASE IV, 1.1
  694. *-- Rev. History: 11/10/1991 - Original Release
  695. *--               08/02/1993 - Jay Parsons - cS added to eliminate
  696. *--               changes to parameter
  697. *-- Calls.......: None
  698. *-- Called by...: Any
  699. *-- Usage.......: StoD("<cString>")
  700. *-- Example.....: ?StoD("19910101")
  701. *-- Returns.....: Date
  702. *-- Parameters..: <cString> = Date string you wish converted to "normal"
  703. *--                           dBASE date. Must be in either YYYYMMDD or
  704. *--                           YYMMDD format.
  705. *-----------------------------------------------------------------------
  706.  
  707.    parameters cString
  708.    private dTest, cS, cMonth, cDay, cYear, dReturn
  709.    
  710.    m->dTest = ctod( "01/02/03" )
  711.    m->cS = cString
  712.    if len( m->cS ) < 8
  713.       m->cS = left( str( year( date() ), 4 ), 2 ) + m->cS
  714.    endif
  715.    m->cYear  = left( m->cS, 4)
  716.    m->cMonth = substr( m->cS, 5, 2)
  717.    m->cDay   = right( m->cS, 2)
  718.    do case
  719.       case month( m->dTest ) = 1
  720.            m->dReturn = ctod( m->cMonth + "/" + m->cDay ;
  721.                         + "/" + m->cYear )
  722.       case day( m->dTest ) = 1
  723.            m->dReturn = ctod( m->cDay + "/" + m->cMonth ;
  724.                         + "/" + m->cYear )
  725.       otherwise
  726.            m->dReturn = ctod( m->cYear + "/" + m->cMonth ;
  727.                         + "/" + m->cDay )
  728.    endcase
  729.  
  730. RETURN m->dReturn
  731. *-- EoF: StoD()
  732.  
  733. FUNCTION Quarter
  734. *-----------------------------------------------------------------------
  735. *-- Programmer..: Bowen Moursund (CIS: 72662,436)
  736. *-- Date........: 02/03/1992
  737. *-- Notes.......: Returns the quarter of the year of a specific date ...
  738. *-- Written for.: dBASE IV, 1.1
  739. *-- Rev. History: 02/03/1992 -- Original Release
  740. *-- Calls.......: None
  741. *-- Called by...: Any
  742. *-- Usage.......: Quarter(<dDate>)
  743. *-- Example.....: ?Quarter({05/25/1992})
  744. *-- Returns.....: Numeric (integer) value from 1 to 4 (or 0 on error )
  745. *-- Parameters..: dDate = date to be checked
  746. *-----------------------------------------------------------------------
  747.  
  748.    parameter dDate
  749.  
  750. RETURN iif(type("dDate")="D",ceiling(month(dDate)/3),0)
  751. *-- EoF: Quarter()
  752.  
  753. FUNCTION Dat2Jul
  754. *-----------------------------------------------------------------------
  755. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  756. *-- Date........: 03/01/1992
  757. *-- Notes.......: Converts dBASE date to Julian # of days (from January
  758. *--               1, 4713 B.C.)  This is the value of the float dBASE
  759. *--               uses to store dates, and is used by astronomers.  Do
  760. *--               not use for dBASE dates before 1582, or without con-
  761. *--               sidering time zones if using for astronomy.
  762. *-- Rev. History: 03/01/1992 -- Original Release
  763. *-- Written for.: dBASE IV
  764. *-- Rev. History: None
  765. *-- Calls.......: None
  766. *-- Called by...: Any
  767. *-- Usage.......: Dat2Jul("<dDate>")
  768. *-- Example.....: ?Dat2Jul(date())
  769. *-- Returns.....: Numeric
  770. *-- Parameters..: dDate = Date to convert to Julian ...
  771. *-----------------------------------------------------------------------
  772.  
  773.    parameters dDate
  774.    
  775. RETURN 2415386 + dDate - ctod( "01/01/01" )
  776. *-- EoF: Dat2Jul()
  777.  
  778. FUNCTION Jul2Dat
  779. *-----------------------------------------------------------------------
  780. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  781. *-- Date........: 03/01/1992
  782. *-- Notes.......: Converts Julian # of days to dBASE Date
  783. *-- Rev. History: 03/01/1992 -- Original Release
  784. *-- Written for.: dBASE IV
  785. *-- Rev. History: None
  786. *-- Calls.......: None
  787. *-- Called by...: Any
  788. *-- Usage.......: Jul2Dat(nJulian)
  789. *-- Example.....: ?Jul2Dat(2448691)
  790. *-- Returns.....: Date
  791. *-- Parameters..: nJulian = Julian date to convert to dBase Date
  792. *-----------------------------------------------------------------------
  793.  
  794.    parameters nJulian
  795.    
  796. RETURN ctod( "01/01/01" ) + (nJulian - 2415386)
  797. *-- EoF: Jul2Dat()
  798.  
  799. FUNCTION FrstNxtMth
  800. *-----------------------------------------------------------------------
  801. *-- Programmer..: Todd Barry (TODDBARRY)
  802. *-- Date........: 08/02/1993
  803. *-- Notes.......: Returns first day of next month
  804. *-- Written for.: dBASE IV, 1.1
  805. *-- Rev. History: 04/04/1992 - Original Release
  806. *--               02/25/1993 - Jay Parsons - shortened
  807. *--               08/02/1993 - Jay Parsons - conformed to use FDoM().
  808. *-- Calls.......: FDoM                 Function in DATES.PRG
  809. *-- Called by...: Any
  810. *-- Usage.......: FrstNxtMth(<dDate>)
  811. *-- Example.....: FrstNxtMth( dDate )
  812. *-- Returns.....: dBASE Date
  813. *-- Parameters..: dDate  -- date to work from ...
  814. *-----------------------------------------------------------------------
  815.    
  816.    parameters dDate
  817.  
  818. RETURN FDoM( dDate - day( dDate ) + 45 )
  819. *-- EoF: FrstNxtMth()
  820.  
  821. FUNCTION FDoM
  822. *-----------------------------------------------------------------------
  823. *-- Programmer..: Kenneth Chan [ZAK] (CIS: 72662,1305)
  824. *-- Date........: 01/05/1993
  825. *-- Notes.......: First Day of Month 
  826. *-- Written for.: dBASE IV, 1.5
  827. *-- Rev. History: 01/05/1993 -- Original Release
  828. *-- Calls.......: None
  829. *-- Called by...: Any
  830. *-- Usage.......: FDoM(<dArg>)
  831. *-- Example.....: ?FDOM(date())
  832. *-- Returns.....: Date
  833. *-- Parameters..: dArg = a Date argument -- function returns first day
  834. *--                      of the month of this date.
  835. *-----------------------------------------------------------------------
  836.  
  837.    parameter dArg
  838.  
  839. RETURN dArg - day( dArg ) + 1
  840. *-- EoF: FDoM()
  841.  
  842. FUNCTION FDoY
  843. *-----------------------------------------------------------------------
  844. *-- Programmer..: Kenneth Chan [ZAK] (CIS: 72662,1305)
  845. *-- Date........: 01/05/1993
  846. *-- Notes.......: Returns January 1 of the year of the date argument
  847. *--               passed to it.
  848. *-- Written for.: dBASE IV, 1.5
  849. *-- Rev. History: 01/05/1993 -- Original Release
  850. *-- Calls.......: None
  851. *-- Called by...: Any
  852. *-- Usage.......: FDoY(<dArg>))
  853. *-- Example.....: FDoY(DATE())
  854. *-- Returns.....: January 1 of the year in dArg
  855. *-- Parameters..: dArg = date data
  856. *-----------------------------------------------------------------------
  857.  
  858.    parameter dArg
  859.    private dJan
  860.  
  861.    m->dJan = m->dArg - day( m->dArg ) + 1 - 28 * ( month( m->dArg ) - 1)
  862.  
  863. RETURN m->dJan - day( m->dJan ) + 1
  864. *-- EoF: FDoY()
  865.  
  866. FUNCTION LDoY
  867. *-----------------------------------------------------------------------
  868. *-- Programmer..: Kenneth Chan [ZAK] (CIS: 72662,1305)
  869. *-- Date........: 01/05/1993
  870. *-- Notes.......: Returns December 31 of year in date argument passed to 
  871. *--               function.
  872. *-- Written for.: dBASE IV, 1.5
  873. *-- Rev. History: 01/05/1993 -- Original Release
  874. *-- Calls.......: LDoM()               Function in DATES.PRG
  875. *-- Called by...: Any
  876. *-- Usage.......: LDoY(<dArg>)
  877. *-- Example.....: ?LDoY(Date())
  878. *-- Returns.....: Last Day of Year
  879. *-- Parameters..: dArg = Date 
  880. *-----------------------------------------------------------------------
  881.  
  882.    parameter dArg
  883.    private dDec
  884.  
  885.    m->dDec = m->dArg - day( m->dArg ) + 28 * ( 13 - month( m->dArg ))
  886.  
  887. RETURN LDoM( m->dDec )
  888. *-- EoF: LDoY()
  889.  
  890. FUNCTION QDate
  891. *-----------------------------------------------------------------------
  892. *-- Programmer..: Kenneth Chan [Zak]  (CIS:72662,1305)
  893. *-- Date........: 01/05/1993
  894. *-- Notes.......: Quicken-style dates
  895. *--               Works best when BELL is OFF and CONFIRM is ON
  896. *--               Works with any SET DATE format
  897. *-- Written for.: dBASE IV, 1.5
  898. *-- Rev. History: 01/05/1993 1.0
  899. *-- Calls.......: FDoM()               Function in DATES.PRG
  900. *--               LDoM()               Function in DATES.PRG
  901. *--               FDoY()               Function in DATES.PRG
  902. *--               LDoY()               Function in DATES.PRG
  903. *--               Strip()              Function in STRINGS.PRG
  904. *-- Called by...: WHEN clause of GET
  905. *-- Usage.......: @ ... GET <dArg> ... WHEN QDate( <dArg> ) ....
  906. *--
  907. *--                 Key         Function
  908. *--                 ---         --------
  909. *--                  T           Today's date
  910. *--                  - or _      Day before
  911. *--                  + or =      Day after
  912. *--                  M           First day of month  |  Repeated press
  913. *--                  H           Last day of month   |  will give you
  914. *--                  Y           First day of year   |  previous/next
  915. *--                  R           Last day of year    |  month/year
  916. *--                  digit       Begin manual date entry
  917. *--
  918. *-- Example.....: dFoo = date()
  919. *--               @ 10,10 get dFoo when QDate( dFoo )
  920. *-- Returns.....: .T.
  921. *-- Parameters..: dArg = Date variable/field you're GETting
  922. *-----------------------------------------------------------------------
  923.  
  924.    parameter dArg
  925.    private lLoop, nRow, nCol, lConfirmOn, nKey, cLastKey, cSimKey,sQdate
  926.  
  927.    m->lLoop      = .t.
  928.    m->nRow       = row()
  929.    m->nCol       = col()
  930.    m->lConfirmOn = ( set( "CONFIRM" ) = "ON" )
  931.    m->cLastKey   = ""
  932.    m->cSimKey    = ""
  933.  
  934.    *-- Save screen in case of Esc
  935.    save screen to sQDate
  936.  
  937.    *-- Check for skip flag (used when SET CONFIRM is ON)
  938.    if type( "x__QDate" ) # "U"
  939.       release x__QDate
  940.  
  941.    else
  942.       do while m->lLoop
  943.       *-- Display current date in special color
  944.       @ nRow, nCol say m->dArg color gb+/n     && <-- use your own color
  945.       *-- Move cursor to beginning of date
  946.       @ nRow, nCol say ""
  947.       *-- Wait for a keypress
  948.       m->nKey = inkey( 0 )
  949.       *-- Convert to uppercase; ignore keys with negative INKEY() values
  950.       m->cKey = upper( chr( max( m->nKey, 0 )))
  951.  
  952.       do case
  953.          case m->cKey = "T"                    && Today
  954.             m->dArg = date()
  955.          case m->cKey = "-" .or. m->cKey = "_" && The day before
  956.             m->dArg = m->dArg - 1
  957.          case m->cKey = "+" .or. m->cKey = "=" && The day after
  958.             m->dArg = m->dArg + 1
  959.          case m->cKey = "M"                    && First day of the month
  960.             m->dArg = FDoM( iif( m->cLastKey = "M", m->dArg - 1,;
  961.                                  m->dArg))
  962.          case m->cKey = "H"                    && Last day of the month
  963.             m->dArg = LDoM( iif( m->cLastKey = "H", m->dArg + 1,;
  964.                                  m->dArg))
  965.           case m->cKey = "Y"                    && First day of the year
  966.              m->dArg = FDoY( iif( m->cLastKey = "Y", m->dArg - 1,;
  967.                                   m->dArg))
  968.           case m->cKey = "R"                    && Last day of the year
  969.              m->dArg = LDoY( iif( m->cLastKey = "R", m->dArg + 1,;
  970.                                   m->dArg))
  971.           case m->cKey $ "0123456789"      && Digit -- manual date entry
  972.              m->lLoop = .f.
  973.              *-- Clear entry and start at beginning
  974.              keyboard chr( 25 ) + chr( 26 ) + m->cKey
  975.           case ( m->nKey >= 32 .and. m->nKey < 127 ) .or. m->nKey > 127
  976.              *-- Ignore invalid keys, like letters and symbols
  977.           case m->nKey = 27 .or. m->nKey = 17   && Esc or Ctrl-Q
  978.              m->lLoop = .f.
  979.              *-- Restore screen and quit
  980.              restore screen from sQDate
  981.              keyboard m->cKey
  982.           otherwise
  983.              m->lLoop = .f.
  984.              *-- Figure out how to simulate last keypress
  985.              *-- If SET CONFIRM is OFF
  986.              if .not. m->lConfirmOn
  987.                 *-- Go back up to date field
  988.                 m->cSimKey = "{UP}"              && Up arrow
  989.                 *-- Create flag variable to skip routine
  990.                 public x__QDate
  991.              endif
  992.              m->cSimKey = m->cSimKey + "{HOME}"
  993.              *-- Recreate keypress
  994.              do case
  995.                 case m->nKey = -400
  996.                    m->cSimKey = m->cSimKey + "{BACKTAB}"
  997.                 otherwise
  998.                    m->cSimKey = m->cSimKey + m->cKey
  999.              endcase
  1000.              *-- Clear entry and "type in" date without separators
  1001.              *-- And simulate last keypress
  1002.              keyboard "{HOME}{CTRL-Y}" + Strip( dtoc( m->dArg ), ;
  1003.                       left( ltrim( dtoc( {} ) ), 1 ) ) + m->cSimKey
  1004.          endcase
  1005.          *-- Save key just pressed
  1006.          m->cLastKey = m->cKey
  1007.  
  1008.       enddo
  1009.  
  1010.    endif
  1011.  
  1012.    *-- release the screen from memory before returning
  1013.    release screen sQDate
  1014.  
  1015. RETURN .t.
  1016. *-- EoF: QDate()
  1017.  
  1018. *-----------------------------------------------------------------------
  1019. *-- For more details on the Hebrew Date routines, see the file included
  1020. *-- called SHANA.TXT, written by Jay Parsons to help explain things.
  1021. *-----------------------------------------------------------------------
  1022.  
  1023. FUNCTION Hebrewdate
  1024. *-----------------------------------------------------------------------
  1025. *-- Programmer..: Jay Parsons (Compuserve 72662,1302)
  1026. *-- Date........: 07/03/1993
  1027. *-- Notes.......: Converts a date to corresponding date on the Hebrew
  1028. *--               calendar.  The date returned is the Hebrew date that
  1029. *--               matches the daylight hours of the given civil date;
  1030. *--               the Hebrew date actually starts the evening before.
  1031. *--                     Of this family of functions, this is the only
  1032. *--               one containing the names of the months, to simplify
  1033. *--               changing the spelling of any of them.  The ruler may
  1034. *--               have to be adjusted if the names are changed, as all
  1035. *--               names must be the same length including padding.
  1036. *-- Written for.: dBASE IV, 2.0
  1037. *-- Rev. History: 03/27/1993 - Jay Parsons - original function
  1038. *--               07/03/1993 - Jay Parsons - nMolen variable added to
  1039. *--               simplify changing names of months
  1040. *--               08/03/1993 - Jay Parsons - revised to conform to
  1041. *--               changes to Dat2Heb() in specification of months.
  1042. *-- Calls.......: Dat2Heb()            Function in DATES.PRG
  1043. *--               IsLeapH()            Function in DATES.PRG
  1044. *-- Called by...: Any
  1045. *-- Usage.......: Hebrewdate( <dDate> )
  1046. *-- Example.....: ? Hebrewdate( {03/27/93} )
  1047. *-- Returns.....: a character string giving the month, day and year of
  1048. *--               the date, such as "Nisan 5, 5753"
  1049. *-- Parameters..: dDate      = a dBASE date
  1050. *-----------------------------------------------------------------------
  1051.  
  1052.    parameters dDate
  1053.    private cDate, cMonths, nMo, cMo, nDay, cDay, nYear, nMolen, nM1
  1054.  
  1055.    * ruler   -> 012345678901234567890123456789012345678901
  1056.    m->cMonths = "Tishri HeshvanKislev Tebeth Shebat Adar   " + ;
  1057.                 "Nisan  Iyar   Sivan  Tammuz Ab     Ellul  "
  1058.    m->cDate = Dat2Heb( dDate )
  1059.    m->nYear = val( right( m->cDate, 4 ) )
  1060.    m->nMo = val( left( m->cDate, 2 ) )
  1061.    m->nDay = val( substr( m->cDate, 4, 2 ) )
  1062.    m->nMolen = len( m->cMonths ) / 12
  1063.    m->nM1 = m->nMo + iif( m->nMo = 0, 6, 0 ) - 1
  1064.    m->cMo = trim( substr( m->cMonths, m->nMolen * m->nM1 + 1, ;
  1065.                           m->nMolen ) ) ;
  1066.             + " " + ltrim( str( m->nDay, 2 ) ) + ", " ;
  1067.             + right( m->cDate, 4 )
  1068.    do case
  1069.       case m->nMo = 0
  1070.            m->cMo = "First "+ m->cMo
  1071.       case m->nMo = 6 .and. isLeapH( m->nYear )
  1072.            m->cMo = "Second " + m->cMo
  1073.    endcase
  1074.  
  1075. RETURN m->cMo
  1076. *-- EoF: HebrewDate()
  1077.  
  1078. FUNCTION Civildate
  1079. *-----------------------------------------------------------------------
  1080. *-- Programmer..: Jay Parsons (Compuserve 72662,1302)
  1081. *-- Date........: 08/02/1993
  1082. *-- Notes.......: Converts a Hebrew calendar date to corresponding date
  1083. *--               on the civil calendar.  The date returned is the civil
  1084. *--               date that matches the daylight hours of the given
  1085. *--               Hebrew date; the Hebrew day actually starts the
  1086. *--               evening before.
  1087. *--                     Supplying the function with a nonexistent 30th
  1088. *--               day of Heshvan or Kishlev is fairly harmless; it will
  1089. *--               return the civil date of the first of the following
  1090. *--               month, the correct date to celebrate a birthday
  1091. *--               falling on the date that does not exist in the given
  1092. *--               year.  This is **NOT** sufficient to avoid problems
  1093. *--               with Adar, or with Yahrzeit for deaths occurring on
  1094. *--               Heshvan 30 or Kishlev 30; users are cautioned against
  1095. *--               finding anniversaries in those cases by supplying the
  1096. *--               Hebrew month and date of the event and a different
  1097. *--               Hebrew year as parameters to this function.
  1098. *--                      In general, reconverting the civil date
  1099. *--               returned to a Hebrew date and comparing it to the
  1100. *--               original Hebrew date furnished to this function will
  1101. *--               disclose any possible problems, as the two Hebrew
  1102. *--               dates will not match.
  1103. *--                      THIS VERSION OF THE FUNCTION IS INCOMPATIBLE
  1104. *--               WITH PREVIOUS ONES--IT INTERPRETS THE PARAMETER
  1105. *--               DIFFERENTLY.
  1106. *-- Written for.: dBASE IV, 2.0
  1107. *-- Rev. History: 03/27/1993 - Original Version.
  1108. *--               08/02/1993 - Jay Parsons - nX and nY made private,
  1109. *--               method of specifying months changed, error returns
  1110. *--               added.
  1111. *-- Calls.......: Kebiah()             Function in DATES.PRG
  1112. *--               Roshashana()         Function in DATES.PRG
  1113. *-- Called by...: Any
  1114. *-- Usage.......: Civildate(<cDate> )
  1115. *-- Example.....: ? Civildate( "05/07/5753" )
  1116. *-- Returns.....: dBase date, the corresponding civil date, or {} if the
  1117. *--               argument fails to specify an existing Hebrew date.
  1118. *-- Parameters..: cDate      = character string holding month, day and
  1119. *--                            year of Hebrew date, MM/DD/YYYY.  Month
  1120. *--                            must be in range 00-12.   Months 01-12
  1121. *--                            correspond to month order in a common
  1122. *--                            year, whether or not the year is common
  1123. *--                            or a leap year, so that "12" means Ellul
  1124. *--                            in any year.  "00" means a date in First
  1125. *--                            Adar and is meaningless in a common year.
  1126. *-----------------------------------------------------------------------
  1127.  
  1128.    parameters cDate
  1129.    private nMo, nDay, nYear, dDate, cKebiah, aDays, nX, nY, dRet
  1130.  
  1131.    * blank date for error returns
  1132.    m->dRet = {}
  1133.    m->nYear = val( right( m->cDate, 4 ) )
  1134.    if m->nYear < 1
  1135.       RETURN dRet
  1136.    endif
  1137.    m->nMo = val( left( m->cDate, 2 ) )
  1138.    if m->nMo < 0 .or. m->nMo > 12
  1139.       RETURN dRet
  1140.    endif
  1141.    m->nDay = val( substr( m->cDate, 4, 2 ) )
  1142.    if m->nDay < 1 .or. m->nDay > 30
  1143.       RETURN dRet
  1144.    endif
  1145.    * find the last day of the Hebrew year preceding this one
  1146.    m->dDate = Roshashana( m->nYear ) - 1
  1147.    * also Rosh Hashanah of this year and its Kebiah
  1148.    m->cKebiah = Kebiah( m->dDate + 1, Roshashana( m->nYear + 1 ) )
  1149.    * set up array of the days in the months, using Kebiah to find
  1150.    * number of days in Heshvan and Kislev, months 2 and 3.  This
  1151.    * array is not really required to add the days of each month
  1152.    * before the needed one to a running total, but it aids
  1153.    * understanding.
  1154.    declare aDays[ 13 ]
  1155.    aDays[ 1 ] = 30
  1156.    aDays[ 2 ] = iif( m->cKebiah $ "EFGLMN", 30, 29 )
  1157.    aDays[ 3 ] = iif( m->cKebiah $ "ABHIJ", 29, 30 )
  1158.    aDays[ 4 ] = 29
  1159.    aDays[ 5 ] = 30
  1160.    * in leap years, add days of two Adars, change specification of
  1161.    * First Adar to month 6 and add one to later months, converting
  1162.    * to their actual positions in the leap year.  Otherwise, add
  1163.    * 29 days of Adar.
  1164.    if m->cKebiah > "G"
  1165.       aDays[ 6 ] = 30
  1166.       aDays[ 7 ] = 29
  1167.       m->nX = 7
  1168.       do case
  1169.          case m->nMo = 0
  1170.               m->nMo = 6
  1171.          case m->nMo > 5
  1172.               m->nMo = m->nMo + 1
  1173.       endcase
  1174.    else
  1175.       if m->nMo = 0
  1176.          RETURN dRet
  1177.       endif
  1178.       aDays[ 6 ] = 29
  1179.       m->nX = 6
  1180.    endif
  1181.    * for the remaining months, alternate 29 and 30 days
  1182.    m->nY = 1
  1183.    do while m->nY < 7
  1184.       aDays[ m->nX + m->nY ] = 29 + mod( m->nY, 2 )
  1185.       m->nY = m->nY + 1
  1186.    enddo
  1187.    * add up the days in months gone by
  1188.    m->nX = 1
  1189.    do while m->nX < m->nMo
  1190.       m->dDate = m->dDate + aDays[ m->nX ]
  1191.       m->nX = m->nX + 1
  1192.    enddo
  1193.    * and the specified days in this month, if they exist
  1194.    if m->nDay <= aDays[ m->nMo ]
  1195.       m->dRet = m->dDate + m->nDay
  1196.    endif
  1197.  
  1198. RETURN m->dRet
  1199. *-- EoF: Civildate()
  1200.  
  1201. FUNCTION Dat2Heb
  1202. *-----------------------------------------------------------------------
  1203. *-- Programmer..: Jay Parsons (Compuserve 72662,1302)
  1204. *-- Date........: 08/03/1993
  1205. *-- Notes.......: Converts a date to corresponding date on the Hebrew
  1206. *--               calendar.  The date returned is the Hebrew date that
  1207. *--               matches the daylight hours of the given civil date;
  1208. *--               the Hebrew date actually starts the evening before.
  1209. *--               Do not use this to convert dates before 1582 C.E.,
  1210. *--               because the dBASE specification of such dates is
  1211. *--               erroneous.
  1212. *-- Written for.: dBASE IV, 2.0
  1213. *-- Rev. History: 03/27/1993 - Original version.
  1214. *--               08/03/1993 - Jay Parsons - conformed to change in
  1215. *--               method of specifying months
  1216. *-- Calls.......: Kebiah()             Function in DATES.PRG
  1217. *--               Roshashana()         Function in DATES.PRG
  1218. *-- Called by...: Any
  1219. *-- Usage.......: Dat2Heb( <dDate> )
  1220. *-- Example.....: ? Dat2Heb( {03/27/93} )
  1221. *-- Returns.....: a character string giving the month, day and year of
  1222. *--               the date in numerals, such as "07/05/5753".  The month
  1223. *--               will be given as the number of that month in a common
  1224. *--               year, whether or not the year is a leap year, so that
  1225. *--               "07" always means Nisan.  A date in First Adar in a
  1226. *--               leap year will be returned as month "00".
  1227. *-- Parameters..: dDate      = a dBASE civil date to convert
  1228. *-----------------------------------------------------------------------
  1229.  
  1230.    parameters dDate
  1231.    private nYear, dFirst, dSecond, cKebiah, aDays, nX, nY, nDay, cD
  1232.  
  1233.    * convert the year to Hebrew year that begins in the civil year
  1234.    m->nYear = year( m->dDate ) + 3761
  1235.    * find Rosh Hashanah in the year
  1236.    m->dFirst = Roshashana( m->nYear )
  1237.    * back up if date is in the preceding Hebrew year
  1238.    if m->dFirst > m->dDate
  1239.       m->nYear = m->nYear - 1
  1240.       m->dSecond = m->dFirst
  1241.       m->dFirst = Roshashana( m->nYear )
  1242.    else
  1243.       m->dSecond = Roshashana( m->nYear + 1 )
  1244.    endif
  1245.    m->cD = "/" + str( m->nYear, 4 )
  1246.    * find number of the day within the Hebrew year, and the Kebiah
  1247.    m->nDay = 1 + m->dDate - m->dFirst
  1248.    m->cKebiah = Kebiah( m->dFirst, m->dSecond )
  1249.    * set up array of the days in the months, using Kebiah to find
  1250.    * number of days in Heshvan and Kislev, months 2 and 3.  This
  1251.    * array is not really required to add the days of each month
  1252.    * to a running total, but it aids understanding.
  1253.    declare aDays[ 13 ]
  1254.    aDays[ 1 ] = 30
  1255.    aDays[ 2 ] = iif( m->cKebiah $ "EFGLMN", 30, 29 )
  1256.    aDays[ 3 ] = iif( m->cKebiah $ "ABHIJ", 29, 30 )
  1257.    aDays[ 4 ] = 29
  1258.    aDays[ 5 ] = 30
  1259.    * in leap years, add days of two Adars, change specification of
  1260.    * First Adar to month 6 and add one to later months, converting
  1261.    * to their actual positions in the leap year.  Otherwise, add
  1262.    * 29 days of Adar.
  1263.    if m->cKebiah > "G"
  1264.       aDays[ 6 ] = 30
  1265.       aDays[ 7 ] = 29
  1266.       m->nX = 7
  1267.    else
  1268.       aDays[ 6 ] = 29
  1269.       m->nX = 6
  1270.    endif
  1271.    * for the remaining months, alternate 29 and 30 days
  1272.    m->nY = 1
  1273.    do while m->nY < 7
  1274.       aDays[ m->nX + m->nY ] = 29 + mod( m->nY, 2 )
  1275.       m->nY = m->nY + 1
  1276.    enddo
  1277.    * reduce the day of the year by the days in months past
  1278.    m->nX = 1
  1279.    do while m->nDay > aDays[ m->nX ]
  1280.       m->nDay = m->nDay - aDays[ m->nX ]
  1281.       m->nX = m->nX + 1
  1282.    enddo
  1283.    * adjust month representation in leap years
  1284.    if m->cKebiah > "G" .and. m->nX > 5
  1285.       m->nX = iif( m->nX = 6, 0, m->nX - 1 )
  1286.    endif
  1287.    m->cD = transform( m->nX, "@L 99" ) + "/" ;
  1288.            + transform( m->nDay, "@L 99" ) + m->cD
  1289.  
  1290. RETURN m->cD
  1291. *-- EoF: Dat2Heb()
  1292.  
  1293. FUNCTION Kebiah
  1294. *-----------------------------------------------------------------------
  1295. *-- Programmer..: Jay Parsons (Compuserve 72662,1302)
  1296. *-- Date........: 03/26/1993
  1297. *-- Notes.......: Kebiah of a year, using Arthur Spier's notation.
  1298. *--                     This tells whether the year in the Hebrew
  1299. *--               calendar is defective, regular or excessive and
  1300. *--               whether or not a leap year.  In order to limit the
  1301. *--               recalculations of Rosh Hashanah in date conversions
  1302. *--               that would be needed if this function were called with
  1303. *--               the year only, it requires the civil dates of the two
  1304. *--               Rosh Hashanahs at start and end as parameters.
  1305. *--                     Error checking is limited to determining whether
  1306. *--               the days of the week of the two dates given and number
  1307. *--               of days between them are possible; no check is made
  1308. *--               that either is the correct date of Rosh Hashanah.
  1309. *-- Written for.: dBASE IV, 2.0
  1310. *-- Rev. History: 03/26/1993 -- Original
  1311. *-- Calls.......: None
  1312. *-- Called by...: Any
  1313. *-- Usage.......: Kebiah(<dRosh1>,dRosh2>)
  1314. *-- Example.....: c = Kebiah( {09/16/1993},{09/06/1994} )
  1315. *-- Returns.....: a letter from A through N, signifying as follows:
  1316. *--                     A - G common year of 12 months
  1317. *--                     H - N leap year of 13 months
  1318. *--                     First day of      length and type     First day
  1319. *--              Letter Rosh Hashanah        of year         of Passover
  1320. *--                A     Monday        353 days, defective      Tuesday
  1321. *--                B     Sabbath       353 days, defective      Sunday
  1322. *--                C     Tuesday       354 days, regular        Thursday
  1323. *--                D     Thursday      354 days, regular        Sabbath
  1324. *--                E     Monday        355 days, excessive      Thursday
  1325. *--                F     Thursday      355 days, excessive      Sunday
  1326. *--                G     Sabbath       355 days, excessive      Tuesday
  1327. *--                H     Monday        383 days, defective      Thursday
  1328. *--                I     Thursday      383 days, defective      Sunday
  1329. *--                J     Sabbath       383 days, defective      Tuesday
  1330. *--                K     Tuesday       384 days, regular        Sabbath
  1331. *--                L     Monday        385 days, excessive      Sabbath
  1332. *--                M     Thursday      385 days, excessive      Tuesday
  1333. *--                N     Sabbath       385 days, excessive      Thursday
  1334. *--                or "" signifying error in dates passed to function.
  1335. *-- Parameters..: dRosh1      = civil date of Rosh Hashanah that starts
  1336. *--                               the year
  1337. *--               dRosh2      = civil date of Rosh Hashanah starting the
  1338. *--                               following year
  1339. *-----------------------------------------------------------------------
  1340.  
  1341.    parameters dRosh1, dRosh2
  1342.    private dR1, dR2, nDays, nDow, cRet
  1343.  
  1344.    m->dR1 = min( m->dRosh1, m->dRosh2 )
  1345.    m->dR2 = max( m->dRosh1, m->dRosh2 )
  1346.    m->nDays = m->dR2 - m->dR1
  1347.    m->nDow = dow( m->dR2 )
  1348.    * Rosh Hashanah cannot be on Sunday, Wednesday or Friday
  1349.    if m->nDow = 1 .or. m->nDow = 4 .or. m->nDow = 6
  1350.       RETURN ""
  1351.    endif
  1352.    m->cRet = space( 7 )     && will return "" if wrong # of days
  1353.    do case
  1354.       * Days       SMTWHFS   && if the char in cRet below the dow
  1355.       * Dows       1234567   && is blank, can't be Rosh Hashanah
  1356.       case m->nDays = 353
  1357.            m->cRet = " A    B"
  1358.       case m->nDays = 354
  1359.            m->cRet = "  C D  "
  1360.       case m->nDays = 355
  1361.            m->cRet = " E  F G"
  1362.       case m->nDays = 383
  1363.            m->cRet = " H  I J"
  1364.       case m->nDays = 384
  1365.            m->cRet = "  K    "
  1366.       case m->nDays = 385
  1367.            m->cRet = " L  M N"
  1368.    endcase
  1369.  
  1370. RETURN trim( substr( m->cRet, dow( m->dR1 ), 1 ) )
  1371. *-- EoF: Kebiah()
  1372.  
  1373. FUNCTION Roshashana
  1374. *-----------------------------------------------------------------------
  1375. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  1376. *-- Date........: 08/02/1993
  1377. *-- Notes.......: Returns date of Rosh Hashanah of a given Hebrew year.
  1378. *--               To find date when Rosh Hashanah occurs in a C.E. year,
  1379. *--               add 3761 to the C.E. Year.  This formidable-looking
  1380. *--               procedure is actually a straightforward matter of
  1381. *--               using the date and time of one Molad Tishri, the
  1382. *--               moment of new moon starting a year, and advancing or
  1383. *--               setting back that date and time by the number of days,
  1384. *--               hours and chalokim in each period of 19 years, then by
  1385. *--               the number in each month within the balance of the
  1386. *--               years.  Since we are concerned only with the molads,
  1387. *--               we need not worry about the number of days in the
  1388. *--               calendar months, but only with the lunar period of 29
  1389. *--               days, 12 hours and 793 chalokim and the number of
  1390. *--               months, giving effect to leap years.
  1391. *--                     A chelek, plural chalokim, is 1/1080 of an hour,
  1392. *--               or 3 1/3 seconds, and is traditionally used for these
  1393. *--               calculations, in part because it avoids the need to
  1394. *--               deal with fractions.
  1395. *--                     Finally, having determined the civil date of the
  1396. *--               Molad Tishri of the proper year and the hour and
  1397. *--               chalokim within the date, we call a separate function
  1398. *--               to determine the applicability of the dechiyoth or
  1399. *--               postponements that may cause Rosh Hashanah to be
  1400. *--               pushed to a later date.
  1401. *-- Written for.: dBASE IV, 2.0
  1402. *-- Rev. History: 03/26/1993 - Original Version.
  1403. *--               08/02/1993 - Jay Parsons - nCycles made private.
  1404. *-- Calls.......: NormalH              Procedure in DATES.PRG
  1405. *--               Dechiyoth            Function in DATES.PRG
  1406. *-- Called by...: Any
  1407. *-- Usage.......: Roshashana( <nYear> )
  1408. *-- Example.....: Roshashana( 1993 + 3761 )
  1409. *-- Returns.....: date       = civil date of Rosh Hashanah in the year
  1410. *-- Parameters..: nYear      = number of year in the Hebrew calendar
  1411. *-----------------------------------------------------------------------
  1412.  
  1413.    parameters nYear
  1414.    private dMoldate, nMolhr, nMolch, nYrs, nMoons, nCycles
  1415.  
  1416.    * we use the Molad of Tishri 5739, October 2, 1978, as the base
  1417.    * for no good reason except it started the most recent cycle.
  1418.    m->dMoldate  = { 10/02/1978 } && The Hebrew date started 6 p.m.
  1419.    m->nMolhr    = 11             && Oct. 1, 1978.  The molad (new
  1420.    m->nMolch    = 614            && moon) was 11 614/1080 hrs later
  1421.    * adjust for each full 19-year cycle ( machzor koton ), which
  1422.    * includes 6939 days, 16 hours and 595 chalokim.
  1423.    * if adjusting backward, go to beginning of the cycle in which
  1424.    * the specified year falls
  1425.    m->nYrs      = m->nYear - 5739   && years of difference to adjust.
  1426.    m->nCycles   = floor( m->nYrs / 19 )
  1427.    m->dMoldate  = m->dMoldate + 6939 * m->nCycles
  1428.    m->nMolhr    = m->nMolhr + 16 * m->nCycles
  1429.    m->nMolch    = m->nMolch + 595 * m->nCycles
  1430.    * adjust for leftover months within the cycle; the formula was
  1431.    * hacked to return the correct number of months for any number
  1432.    * of years from 0 through 19 at the start of a 19-year cycle.
  1433.    m->nYrs      = m->nYrs - 19 * m->nCycles
  1434.    m->nMoons    = int( .01 + m->nYrs * 12.374 )
  1435.    * one lunar month is 29 days 12 hours 793 chalokim
  1436.    m->dMoldate  = m->dMoldate +  29 * m->nMoons
  1437.    m->nMolhr    = m->nMolhr   +  12 * m->nMoons
  1438.    m->nMolch    = m->nMolch   + 793 * m->nMoons
  1439.    do NormalH with m->dMoldate, m->nMolhr, m->nMolch
  1440.  
  1441. RETURN m->dMoldate + Dechiyoth( m->dMolDate, m->nMolhr, m->nMolch )
  1442. *-- EoF: Roshashana()
  1443.  
  1444. FUNCTION Dechiyoth
  1445. *-----------------------------------------------------------------------
  1446. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  1447. *-- Date........: 03/26/1993
  1448. *-- Notes.......: Adjusts date of Rosh Hashanah for the four dechiyoth
  1449. *--               ( postponements ) required to regularize the calendar
  1450. *--               and prevent either two days in a row of Sabbath at Yom
  1451. *--               Kippur or Hoshanah Rabbah falling on the Sabbath.
  1452. *--                     Days, hours and chalokim  are measured from
  1453. *--               6 p.m. Friday evening, considered the beginning of the
  1454. *--               Sabbath for calendar purposes.
  1455. *-- Written for.: dBASE IV, 2.0
  1456. *-- Rev. History: 03/26/1993
  1457. *-- Calls.......: IsLeapH              Function in DATES.PRG
  1458. *-- Called by...: Roshashana(), primarily
  1459. *-- Usage.......: Dechiyoth( <dDate>, <nHrs>, <nChalokim> )
  1460. *-- Example.....: nDay = Dechiyoth( {10/02/1978}, 11, 614 )
  1461. *-- Returns.....: date       = civil date of Rosh Hashanah
  1462. *-- Parameters..: dDate      = civil date of Molad Tishri
  1463. *--               nHrs       = hour of Molad Tishri past 6 pm
  1464. *--               nChalokim  = chalokim past the hour of Molad Tishri
  1465. *-----------------------------------------------------------------------
  1466.  
  1467.    parameters dDate, nHrs, nChalokim
  1468.    private nMoldow, nFirst, nNidcheh
  1469.  
  1470.    m->nMoldow = mod( dow( m->dDate ), 7 )
  1471.    m->nNidcheh = 0
  1472.    m->nFirst = m->nMoldow
  1473.    * 1) if Molad Tishri is after noon, new moon could not be seen
  1474.    *    anywhere that day, so Rosh Hashanah is pushed off (nidcheh)
  1475.    *    to the next day--it is to be celebrated on the day the new
  1476.    *    moon could first be seen.
  1477.    if m->nHrs * 1080 + m->nChalokim > 18 * 1080
  1478.       m->nNidcheh = 1
  1479.       m->nFirst = m->nFirst + 1
  1480.    endif
  1481.    * 2) if Rosh Hashanah would be Sunday, Wednesday or Friday, it
  1482.    *    is nidcheh ( again if dechiyah 1 applied ) so that Yom
  1483.    *    Kippur will not fall on Friday or Sunday creating two days
  1484.    *    of Sabbath in a row, nor Hoshanah Rabbah fall on Sabbath.
  1485.    if m->nFirst = 1 .or. m->nFirst = 4 .or. m->nFirst = 6
  1486.       m->nNidcheh = m->nNidcheh + 1
  1487.    endif
  1488.    * 3) if Molad Tishri in a common year is Tuesday and the next
  1489.    *    Molad Tishri would be after noon of the Sabbath, this Rosh
  1490.    *    Hashanah is nidcheh twice so the next Rosh Hashanah will
  1491.    *    not have to be nidcheh--the result would be that this year
  1492.    *    would have 356 days, too many.
  1493.    if .not. IsLeapH( year( m->dDate ) + 3761 ) .and. m->nMoldow  = 3 ;
  1494.       .and. 1080 * m->nHrs + m->nChalokim > 9 * 1080 + 204   && 9 hr 204
  1495.       m->nNidcheh = 2
  1496.    endif
  1497.    * 4) if Molad Tishri in a common year following a leap year
  1498.    *    occurs Monday morning so late that the preceding leap year
  1499.    *    must have started on Thursday, this Rosh Hashanah is
  1500.    *    nidcheh so the preceding leap year will not be left with
  1501.    *    382 days, too few.
  1502.    if IsLeapH( year( m->dDate ) + 3760 ) .and. m->nMoldow = 2 ;
  1503.       .and. 1080 * m->nHrs + m->nChalokim > 15 * 1080 + 589 && 15 hr 589
  1504.       m->nNidcheh = 1
  1505.    endif
  1506.  
  1507. RETURN m->nNidcheh
  1508. *-- EoF: Dechiyoth()
  1509.  
  1510. FUNCTION IsLeapH
  1511. *-----------------------------------------------------------------------
  1512. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  1513. *-- Date........: 03/27/1993
  1514. *-- Notes.......: Returns .T. or .F. whether a Hebrew year is a leap
  1515. *--               year.  The formula is a hack; it returns .T. when the
  1516. *--               position of the year in the cycle is 3, 6, 8, 11, 14,
  1517. *--               17 or 19 ( the last, because its modulus 19 is 0. )
  1518. *-- Written for.: dBASE IV, 2.0
  1519. *-- Rev. History: 03/27/1993 -- Original
  1520. *-- Calls.......: None
  1521. *-- Called by...: Any
  1522. *-- Usage.......: IsLeapH( <nYear> )
  1523. *-- Example.....: ? IsLeapH( 1993 + 3761 )
  1524. *-- Returns.....: logical    = true if the year is a leap year, or false
  1525. *-- Parameters..: nYear      = number of the year on the Hebrew calendar
  1526. *-----------------------------------------------------------------------
  1527.  
  1528.    parameters nYear
  1529.    private nY
  1530.  
  1531.    m->nY = mod( m->nYear, 19 )
  1532.  
  1533. RETURN mod( m->nY + int( ( m->nY + 3 ) / 11 ), 3 ) = 0
  1534. *-- EoF: IsLeapH()
  1535.  
  1536. PROCEDURE NormalH
  1537. *-----------------------------------------------------------------------
  1538. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  1539. *-- Date........: 03/26/1993
  1540. *-- Notes.......: Normalize date and numbers of hours and chalokim
  1541. *-- Written for.: dBASE IV, 2.0
  1542. *-- Rev. History: 03/26/1993 -- Original
  1543. *-- Calls.......: None
  1544. *-- Called by...: Any
  1545. *-- Usage.......: DO NormalH with <dDate>, <nHrs>, <nChalokim>
  1546. *-- Example.....: DO Normalh with {03/13/1993}, 39, 1452
  1547. *-- Parameters..: dDate         = a dBASE civil date
  1548. *--               nHrs          = number of hours
  1549. *--               nChalokim     = number of chalokim
  1550. *-- Side Effects: This procedure changes its parameters.
  1551. *-----------------------------------------------------------------------
  1552.  
  1553.    parameters dDate, nHrs, nChalokim
  1554.  
  1555.    m->nHrs       = m->nHrs + floor( m->nChalokim / 1080 )
  1556.    m->nChalokim  = mod( m->nChalokim, 1080 )
  1557.    m->dDate      = m->dDate + floor( m->nHrs / 24 )
  1558.    m->nHrs       = mod( m->nHrs, 24 )
  1559.  
  1560. RETURN
  1561. *-- EoP: NormalH
  1562.  
  1563. *-----------------------------------------------------------------------
  1564. *-- End of the Jewish Date Routines
  1565. *-----------------------------------------------------------------------
  1566.  
  1567. FUNCTION MDY_UDF
  1568. *-----------------------------------------------------------------------
  1569. *-- Programmer..: Angus Scott-Fleming (CIS: 75500,3223)
  1570. *-- Date........: 11/25/1992
  1571. *-- Note........: Print date nicely, regardless of SET CENTURY setting
  1572. *--             : MDY({01/01/80})     prints as "January 01, 80"
  1573. *--             : MDY_UDF({01/01/80}) prints as "January 1, 1980"
  1574. *-- Written for.: dBASE IV 1.5+
  1575. *-- Rev. History: 11/25/1992 -- Original
  1576. *-- Calls.......: None
  1577. *-- Called by...: Any
  1578. *-- Usage.......: MDY_UDF(<dDate>)
  1579. *-- Example.....: ? MDY_Udf(ctod("01/01/92"))
  1580. *-- Returns.....: character representation of current date
  1581. *-- Parameters..: dDate = date to modify
  1582. *-----------------------------------------------------------------------
  1583.  
  1584.    parameters dDate
  1585.  
  1586.    if .not. IsBlank(m->dDate)
  1587.       RETURN cmonth(m->dDate)+" "+iif(day(m->dDate)<10,;
  1588.              str(day(m->dDate),1),;
  1589.              str(day(m->dDate),2))+", "+str(year(m->dDate),4)
  1590.    else
  1591.      RETURN ""
  1592.    endif
  1593. *-- EoF: MDY_UDF()
  1594.  
  1595. FUNCTION SWorkDays
  1596. *-----------------------------------------------------------------------
  1597. *-- Programmer..: Jay Parsons (CIS: 72662,1302) 
  1598. *-- Date........: 06/19/1993
  1599. *-- Notes.......: Returns workdays between two dates, excluding the
  1600. *--               first but including the last.
  1601. *--                     This function is a shortcut that works only if
  1602. *--               all of the following assumptions are true:
  1603. *--                     1) Workdays are Monday through Friday.
  1604. *--                     2) Holidays are: New Year's Day   ( 1/1 )
  1605. *--                                      Independence Day ( 7/4 )
  1606. *--                                      Christmas Day    ( 12/25 )
  1607. *--                        and any selection of floating holidays found
  1608. *--                        in the Holiday() function, provided their
  1609. *--                        letters are inserted in "cHols" in this
  1610. *--                        function.  It can be made an additional
  1611. *--                        parameter if desired.
  1612. *--                     3) If any holiday falls on Saturday or Sunday,
  1613. *--                        it is observed on the closest workday, except
  1614. *--                        New Year's Day which is observed on the next
  1615. *--                        workday.
  1616. *--               For a more sophisticated treatment of holidays, see
  1617. *--               the functions MakeHols() and WorkDays() in this file.
  1618. *-- Written for.: dBASE IV, 1.1 or higher.
  1619. *-- Rev. History: 06/19/1993 - original function.
  1620. *-- Calls.......: HoliCount()          Function in DATES.PRG
  1621. *--               IsLeap()             Function in DATES.PRG
  1622. *--               Age2()               Function in DATES.PRG
  1623. *--               FDoY()               Function in DATES.PRG
  1624. *--               XWorked()            Function in DATES.PRG
  1625. *--               WeekDays()           Function in DATES.PRG
  1626. *-- Called by...: Any
  1627. *-- Usage.......: SWorkDays(<dDate1>,<dDate2>)
  1628. *-- Example.....: SWorkDays(date(),{08/27/94})
  1629. *-- Returns.....: Number of workdays in the period between the dates,
  1630. *--               excluding the first and including the last, or -1
  1631. *--               for error.
  1632. *-- Parameters..: dDate1, dDate2 -- dates limiting the period.                        etc ...)
  1633. *-----------------------------------------------------------------------
  1634.  
  1635.    parameters dDate1, dDate2
  1636.    private dStart, dEnd, nWork, nYr, cHols
  1637.  
  1638.    m->cHols = "PMLCT"    && codes for five floating holidays
  1639.                          && President's Day, Memorial Day
  1640.                          && Labor Day, Columbus Day, Thanksgiving
  1641.    * deal with improper arguments
  1642.    if type("dDate1") # "D" .or. type("dDate2") # "D"
  1643.       RETURN -1
  1644.    endif
  1645.  
  1646.    * and reversal of order
  1647.    m->dStart = min( m->dDate1, m->dDate2 )
  1648.    m->dEnd = max( m->dDate1, m->dDate2 )
  1649.  
  1650.    m->nWork = 0
  1651.    * Full years contain 52 weeks of 5 workdays each, less all the
  1652.    * holidays, plus one day the same day of the week as the
  1653.    * starting date of the year, and in leap years one more day.
  1654.    * We deal with calendar years and two stub periods to avoid the
  1655.    * possibility that a period of one year measured from the
  1656.    * starting date may contain more or less than a full year of
  1657.    * holidays--a year from January 2 to the next January 2 may
  1658.    * contain 0, 1 or 2 Leap Year holidays.  52 * 5 = 260, 260 -
  1659.    * 3 holidays always included = 257.
  1660.    m->nYr = year( m->dStart )     && start at 1/1 of start year
  1661.    do while year( m->dEnd ) > m->nYr
  1662.       m->nWork = m->nWork + 257 - len( m->cHols )
  1663.       m->nWork = m->nWork + XWorked( iif( IsLeap( m->nYr ), 2, 1 ),;
  1664.                  dow( ctod( "01/01/" + str( m->nYr, 4 ) ) ) )
  1665.       m->nYr = m->nYr + 1
  1666.    enddo
  1667.  
  1668.    * now adjust for the weekdays of the initial year through the
  1669.    * start date
  1670.    m->nWork = m->nWork ;
  1671.               - WeekDays( FDoY( m->dStart ) - 1, m->dStart )
  1672.    * and the holidays in that stub period
  1673.    m->nWork = m->nWork + HoliCount( m->dStart, m->cHols )
  1674.  
  1675.    * and for the weekdays of the final partial year
  1676.    m->nWork = m->nWork ;
  1677.               + WeekDays( FDoy( m->dEnd ) - 1, m->dEnd )
  1678.    * and the holidays in that stub period
  1679.    m->nWork = m->nWork - HoliCount( m->dEnd, m->cHols )
  1680.  
  1681. RETURN m->nWork
  1682. *-- EoF: SWorkDays()
  1683.  
  1684. FUNCTION WeekDays
  1685. *-----------------------------------------------------------------------
  1686. *-- Programmer..: Jay Parsons (CIS: 72662,1302) 
  1687. *-- Date........: 06/19/1993
  1688. *-- Notes.......: Returns number of days that are not Saturdays or
  1689. *--               Sundays within a range of dates.  Excludes beginning
  1690. *--               date and includes ending date.  Range must be less
  1691. *--               than one year.  See "SWorkDays()" for method of
  1692. *--               calculating weekdays in a number of full years.
  1693. *--               Does not consider holidays.
  1694. *-- Written for.: dBASE IV, 1.1 or higher.
  1695. *-- Rev. History: 06/19/1993 - original function.
  1696. *-- Calls.......: Age2()               Function in DATES.PRG
  1697. *--               XWorked()            Function in DATES.PRG
  1698. *-- Called by...: Any
  1699. *-- Usage.......: WeekDays(<dDate1>,<dDate2>)
  1700. *-- Example.....: WeekDays( {06/19/93},{12/31/93} )
  1701. *-- Returns.....: Number of weekdays in the period between the dates,
  1702. *--               excluding the first and excluding the last, or -1 for
  1703. *--               error.
  1704. *-- Parameters..: dDate1    -- starting date.
  1705. *--               dDate2    -- ending date.
  1706. *-----------------------------------------------------------------------
  1707.  
  1708.    parameters dDate1, dDate2
  1709.    private dStart, dEnd, nWork
  1710.  
  1711.    * deal with improper arguments
  1712.    if type("dDate1") # "D" .or. type("dDate2") # "D"
  1713.       RETURN -1
  1714.    endif
  1715.  
  1716.    * reversal of order
  1717.    m->dStart = min( m->dDate1, m->dDate2 )
  1718.    m->dEnd = max( m->dDate1, m->dDate2 )
  1719.  
  1720.    * and periods of a year or more
  1721.    if Age2( m->dStart + 1, m->dEnd ) > 0
  1722.       RETURN -1
  1723.    endif
  1724.  
  1725.    * 5 days per week for the whole weeks
  1726.    m->nWork = 5 * int( ( m->dEnd - m->dStart ) / 7 )
  1727.  
  1728.    * and the stub days ( revised to accommodate a mod() bug )
  1729.    m->nWork = m->nWork ;
  1730.               + Xworked( mod( fixed( m->dEnd - m->dStart ), 7 ), ;
  1731.                          dow( m->dStart + 1 ) )
  1732. RETURN m->nWork
  1733. *-- Eof: WeekDays()
  1734.  
  1735. FUNCTION XWorked
  1736. *-----------------------------------------------------------------------
  1737. *-- Programmer..: David Frankenbach (CIS: 72147,2635)
  1738. *-- Date........: 06/20/1993
  1739. *-- Notes.......: Returns number of workdays in a stub period of 0 - 6
  1740. *--               days beginning on the day of the week indicated.  Does
  1741. *--               not consider holidays, treats workdays as Monday thru
  1742. *--               Friday.
  1743. *-- Written for.: dBASE IV, 1.1 or higher.
  1744. *-- Rev. History: 06/20/1993 - original function.
  1745. *-- Calls.......: None
  1746. *-- Called by...: None
  1747. *-- Usage.......: XWorked(<nXtra>,<nDow>)
  1748. *-- Example.....: XWorked( 5, 3 )
  1749. *-- Returns.....: Number of workdays in the period, or -1 for error.
  1750. *-- Parameters..: nXtra     -- days in the stub period.
  1751. *--               nDoW      -- dow() of first day of the stub period.
  1752. *-----------------------------------------------------------------------
  1753.  
  1754.    parameters nXtra, nDoW
  1755.  
  1756.    if m->nXtra < 0 .or. m->nXtra > 6 .or. m->nDoW < 1 .or. m->nDoW > 7
  1757.       RETURN -1
  1758.    endif
  1759.  
  1760.    if ( m->nDoW = 1 )
  1761.       RETURN max( ( m->nXtra - 1 ), 0 )
  1762.    else
  1763.       RETURN min( m->nXtra, max( 7 - m->nDoW, 0 ) ) ;
  1764.                   + max( m->nXtra - 9 + m->nDoW, 0 )
  1765.     endif
  1766.  
  1767. RETURN -1
  1768. *-- EoF: XWorked()
  1769.  
  1770. FUNCTION HoliCount
  1771. *-----------------------------------------------------------------------
  1772. *-- Programmer..: Jay Parsons (CIS: 72662,1302) 
  1773. *-- Date........: 06/19/1993
  1774. *-- Notes.......: Returns number of holidays that fall in the portion of
  1775. *--               a calendar year ending with a given date.  Always
  1776. *--               includes New Year's Day, transferred if required to
  1777. *--               the 2d or 3d, and July 4 and Xmas, each transferred if
  1778. *--               required to the nearest day not Saturday or Sunday.
  1779. *--               Other holidays are included ( but not transferred ) if
  1780. *--               their codes for the Holiday() function are included in
  1781. *--               the cHols argument.
  1782. *--               Does not include the numbers of Saturdays and Sundays
  1783. *--               in the value returned.
  1784. *-- Written for.: dBASE IV, 1.1 or higher.
  1785. *-- Rev. History: 06/19/1993 - original function.
  1786. *-- Calls.......: Annivrsry()          Function in DATES.PRG
  1787. *--               Holiday()            Function in DATES.PRG
  1788. *--               FDoY()               Function in DATES.PRG
  1789. *--               HolXFer()            Function in DATES.PRG
  1790. *-- Called by...: Any
  1791. *-- Usage.......: Holicount(<dDate>,<cHols>)
  1792. *-- Example.....: Holicount( {06/19/93}, "PMLCT" )
  1793. *-- Returns.....: Number of holidays
  1794. *-- Parameters..: dDate     -- date ending the period
  1795. *--               cHols     -- list of holidays for function Holiday()
  1796. *-----------------------------------------------------------------------
  1797.  
  1798.    parameters dDate, cHols
  1799.    private dSt, dThis, nH, nHols
  1800.  
  1801.    m->nH = 1
  1802.    m->nHols = 0
  1803.    m->dSt = FDoY( m->dDate )                 && first day of our year
  1804.    do while m->nH < len( m->cHols ) + 4
  1805.       do case
  1806.          case m->nH <= len( m->cHols )      && a day in cHols
  1807.               m->dThis = Holiday( year( m->dSt ), ;
  1808.                          substr( m->cHols, m->nH, 1 ) )
  1809.          case m->nH = len( m->cHols )       && New Year's Day
  1810.               m->dThis = HolXFer( m->dSt, "17", "F" )
  1811.          case m->nH = len( m->cHols ) + 2   && Independence Day
  1812.               m->dThis = ctod( "07/04/" + str( year( m->dDate ), 4 ) )
  1813.               m->dThis = HolXFer( m->dThis, "17", "Y" )
  1814.          case m->nH = len( m->cHols ) + 3   && Christmas
  1815.               m->dThis = ctod( "12/25/" + str( year( m->dDate ), 4 ) )
  1816.               m->dThis = HolXFer( m->dThis, "17", "Y" )
  1817.       endcase
  1818.       if Annivrsry( m->dThis, m->dSt, m->dDate )
  1819.          m->nHols = m->nHols + 1
  1820.       endif
  1821.       m->nH = m->nH + 1
  1822.    enddo
  1823.  
  1824. RETURN m->nHols
  1825. *-- EoF: Holicount()
  1826.  
  1827. FUNCTION HolXfer
  1828. *-----------------------------------------------------------------------
  1829. *-- Programmer..: Jay Parsons (CIS: 72662,1302) 
  1830. *-- Date........: 06/19/1993
  1831. *-- Notes.......: Returns date of celebration of a holiday.  This will
  1832. *--               be the date given unless it falls on one of the days
  1833. *--               of the week whose dow() values are given as chars in
  1834. *--               the cDows parameter, in which case it will be
  1835. *--               transferred to the first available date without such
  1836. *--               a dow() either forward, backward or to the nearest
  1837. *--               open date depending on the third cDir parameter being
  1838. *--               "F", "B" or "Y".
  1839. *-- Written for.: dBASE IV, 1.1 or higher.
  1840. *-- Rev. History: 06/19/1993 - original function.
  1841. *-- Calls.......: None
  1842. *-- Called by...: Any
  1843. *-- Usage.......: HolXfer(<dDate>,<cDows>,<cDir>)
  1844. *-- Example.....: HolXfer( {12/25/93}, "17"," ")
  1845. *-- Returns.....: Date holiday is celebrated
  1846. *-- Parameters..: dDate     -- date of the actual holiday.
  1847. *--               cDoWs     -- string of all dow() values from which it
  1848. *--                            must be transferred if it falls on one.
  1849. *--               cDir      -- character "F" for forward transfer only,
  1850. *--                            "B" for backward transfer only or "Y" for
  1851. *--                            either way, forward being preferred.
  1852. *-------------------------------------------------------------------------------
  1853.  
  1854.    parameters dDate, cDoWs, cDir
  1855.    private nDir, dRet, nMoves
  1856.  
  1857.    m->dRet = m->dDate
  1858.    do case
  1859.       case upper( m->cDir ) = "F"
  1860.            m->nDir = 1
  1861.       case upper( m->cDir ) = "B"
  1862.            m->nDir = -1
  1863.       case upper( m->cDir ) = "Y"
  1864.            m->nDir = 0
  1865.       otherwise
  1866.            RETURN m->dRet
  1867.    endcase
  1868.    m->nMoves = 1
  1869.    do while str( dow( m->dRet ), 1 ) $ m->cDoWs
  1870.       if m->nDir # 0
  1871.          m->dRet = m->dRet + m->nDir
  1872.       else
  1873.          if mod( m->nMoves, 2 ) = 1
  1874.             m->dRet = m->dRet + m->nMoves
  1875.          else
  1876.             m->dRet = m->dRet - m->nMoves
  1877.          endif
  1878.          m->nMoves = m->nMoves + 1
  1879.       endif
  1880.    enddo
  1881.  
  1882. RETURN m->dRet
  1883. *--     EoF: HolXFer()
  1884.  
  1885. *-----------------------------------------------------------------------
  1886. *-- WORKDAYS routines:
  1887. *--     Note to the user: the Makehols.dbf file included is for 
  1888. *--     demonstration only, and contains a bizarre set of holidays that 
  1889. *--     are surely incorrect for any real organization.  Edit it as 
  1890. *--     needed for your organization, while retaining the structure.  
  1891. *--     See the notes to MakeHols() for the significance of the various 
  1892. *--     fields and values allowed therein.
  1893. *--                 Jay Parsons (CIS: 72662,1302)
  1894. *-----------------------------------------------------------------------
  1895.  
  1896. FUNCTION WorkDays
  1897. *-----------------------------------------------------------------------
  1898. *-- Programmer..: Jay Parsons (CIS: 72662,1302) 
  1899. *-- Date........: 08/02/1993
  1900. *-- Notes.......: Returns workdays between two dates, excluding the
  1901. *--               first but including the last.
  1902. *--                     This function uses a .dbf named "HolsYYYY.dbf",
  1903. *--               with "YYYY" being the four digits of the year, for
  1904. *--               each calendar year of interest.  Such a .dbf will be
  1905. *--               created, if possible, if it does not exist by the
  1906. *--               MakeHols() function included elsewhere in this file.
  1907. *--               The .dbf may be created otherwise; the only
  1908. *--               requirements are that its first field must be a date
  1909. *--               and that it be both sorted and ordered on that field
  1910. *--               tag "Holdate".  It is suggested that it include a
  1911. *--               second field of character type, length 40, for the
  1912. *--               name of the holiday.  The HolsYYYY .dbf must contain
  1913. *--               one record for each non-working day of the year,
  1914. *--               including all Sundays and the like.
  1915. *--                     Because this function calls MakeHols() to check
  1916. *--               the timestamp of MakeHols.dbf against that of
  1917. *--               HolsYYYY.dbf, Makehols.dbf must exist even if
  1918. *--               HolsYYYY.dbf is up to date.
  1919. *--                     This function may of course be written to use an
  1920. *--               array for the non-working days instead of a .dbf.
  1921. *--               That will require considerably more memory but may
  1922. *--               increase speed of access depending on caching, at the
  1923. *--               price of requiring rebuilding/reloading the array when
  1924. *--               needed.
  1925. *-- Written for.: dBASE IV, 1.1 or higher.
  1926. *-- Rev. History: 06/19/1993 - original function.
  1927. *--               08/02/1993 - Jay Parsons - cNear and lOk made private.
  1928. *-- Calls.......: MakeHols()           Function in DATES.PRG
  1929. *--               IsLeap()             Function in DATES.PRG
  1930. *--               DoY()                Function in DATES.PRG
  1931. *-- Called by...: None
  1932. *-- Usage.......: WorkDays(<dDate1>,<dDate2>)
  1933. *-- Example.....: WorkDays(date(),{08/27/94})
  1934. *-- Returns.....: Number of workdays in the period between the dates,
  1935. *--               excluding the first and excluding the last, or -1 for
  1936. *--               error.
  1937. *-- Parameters..: dDate1, dDate2 -- dates limiting the period.                        etc ...)
  1938. *-----------------------------------------------------------------------
  1939.  
  1940.    parameters dDate1, dDate2
  1941.    private dStart, dEnd, nWork, nSt, cHols, cNear, lOk
  1942.  
  1943.    * deal with improper arguments
  1944.    if type("dDate1") # "D" .or. type("dDate2") # "D"
  1945.       RETURN -1
  1946.    endif
  1947.  
  1948.    * and reversal of order
  1949.    m->dStart = min( m->dDate1, m->dDate2 )
  1950.    m->dEnd = max( m->dDate1, m->dDate2 )
  1951.  
  1952.    m->nWork = 0
  1953.    if .not. file( "MAKEHOLS.DBF" )
  1954.       RETURN -1
  1955.    endif
  1956.    m->cNear = set("NEAR")
  1957.    set near on
  1958.  
  1959.    m->nYr = year( m->dStart )
  1960.    do while m->nYr <= year( m->dEnd )
  1961.       m->lOk = MakeHols( m->nYr )
  1962.       if .not. m->lOk
  1963.          set near &cNear.
  1964.          RETURN -1
  1965.       endif
  1966.       use "HOLS" + str( m->nYr, 4 ) order HolDate ;
  1967.           alias Holsfile in select()
  1968.       * Add workdays in whole year, except final year
  1969.       if m->nYr # year( m->dEnd )
  1970.          m->nWork = m->nWork ;
  1971.                     + iif( IsLeap( m->nYr ), 366, 365 ) ;
  1972.                      - reccount( "Holsfile" )
  1973.       else
  1974.          * for ending year, add earlier days - holidays
  1975.          m->nWork = m->nWork + DoY( m->dEnd )
  1976.          seek m->dEnd
  1977.          m->nWork = m->nWork - iif( eof(), reccount(), ;
  1978.                        recno() - iif( found(), 0, 1 ) )
  1979.       endif
  1980.       * For starting year, remove earlier days - holidays
  1981.       if m->nYr = year( m->dStart )
  1982.          m->nWork = m->nWork - DoY( m->dStart )
  1983.          seek m->dStart
  1984.          m->nWork = m->nWork + iif( eof(), reccount(), ;
  1985.                     recno() - iif( found(), 0, 1 ) )
  1986.       endif
  1987.       m->nYr = m->nYr + 1
  1988.       use
  1989.    enddo
  1990.    set near &cNear.
  1991.  
  1992. RETURN m->nWork
  1993. *-- EoF: WorkDays()
  1994.  
  1995. FUNCTION MakeHols
  1996. *-----------------------------------------------------------------------
  1997. *-- Programmer..: Jay Parsons (CIS: 72662,1302) 
  1998. *-- Date........: 08/03/1993
  1999. *-- Notes.......: Makes a .dbf file of name "HolsYYYY.dbf" if the file
  2000. *--               Makehols.dbf is found, where "YYYY" in the name will
  2001. *--               be the four digits of the year.  The resulting file
  2002. *--               will contain a record for each non-working day of the
  2003. *--               year and will be sorted in order of date and tagged
  2004. *--               by date tag "HolDate".  Returns .T. if successful, or
  2005. *--               .F.  If the file "HolsYYYY.dbf" already exists, it
  2006. *--               will be rebuilt only if older than "Makehols.dbf."
  2007. *--               This function uses a .dbf called "Makehols.dbf".  If
  2008. *--               it cannot be found, does not exist, the function
  2009. *--               fails.  Makehols.dbf may or may not be provided with
  2010. *--               this library.  Its structure is:
  2011. *--                       HOLTYPE   C  1   N    Type of holiday
  2012. *--                       FIRSTDAY  C  6   N    date within the year*
  2013. *--                       NUMDOW    N  1 0 N    dow()
  2014. *--                       XFER      C  1   N    Transfer code
  2015. *--                       XTEND     C  1   N    Extendability code
  2016. *--                       HOLNAME   C 40   N    Name of the holiday
  2017. *--               *The FIRSTDAY field is used for other purposes for
  2018. *--               some holiday types.  See below
  2019. *--               Values acceptable in the Makehols.dbf fields are:
  2020. *--                     Holtype:  W = weekly holiday, e.g. Sunday
  2021. *--                               X = fixed holiday, e.g. Xmas
  2022. *--                               F = floating holiday, e.g. Labor Day
  2023. *--                               J = Jewish holiday
  2024. *--                               E = Easter or day calculated from it
  2025. *--                     FirstDay: for W types, ignored
  2026. *--                               for X types, the date "MM/DD/"
  2027. *--                               for F types, first date on which
  2028. *--                                     it can occur, "MM/DD/", or the
  2029. *--                                     letter to pass to the Holidays()
  2030. *--                                     function if supported in it.
  2031. *--                               for J types, the month and day in the
  2032. *--                                     Hebrew calendar, such as "01/02"
  2033. *--                                     for the second day of Rosh
  2034. *--                                     Hashanah.  Dates that occur
  2035. *--                                     twice in the civil year will be
  2036. *--                                     included twice.  The month is
  2037. *--                                     understood as the month in a
  2038. *--                                     common year, Nisan being 7.  If
  2039. *--                                     month 6, Adar, is specified, the
  2040. *--                                     holiday will be that date in
  2041. *--                                     Second Adar in leap years.
  2042. *--                                     To specify a date in I Adar of
  2043. *--                                     a leap year, use month "00".
  2044. *--                               for E types, the val() of this field
  2045. *--                                     will be used as a displacement
  2046. *--                                     from Easter, such as "-46" for
  2047. *--                                     Ash Wednesday.
  2048. *--                     NumDow:   dow() value of the holiday.  Needed
  2049. *--                               for W types, and for F types if
  2050. *--                               Firstday has a nonzero val(), ignored
  2051. *--                               for others.
  2052. *--                     XFer:     "F", "B", "Y" or other, meaning that
  2053. *--                               if the holiday falls on a Weekly-type
  2054. *--                               non-working day, transfer it:
  2055. *--                                      F = Forward,
  2056. *--                                      B = Backward,
  2057. *--                                      Y = Yes, either way, or
  2058. *--                                  other = not at all,
  2059. *--                               to the nearest working day in that
  2060. *--                               direction.  If "Y" is specified, a
  2061. *--                               transfer date ahead will be preferred
  2062. *--                               to one the same number of days back.
  2063. *--                     Xtend:    Same characters as Xfer, but here they
  2064. *--                               indicate whether the holiday is to be
  2065. *--                               extended to cover the intervening day
  2066. *--                               if it falls one day away from a weekly
  2067. *--                               holiday ( example--the Friday after
  2068. *--                               Thanksgiving for some schools ).  Mark
  2069. *--                               Thanksgiving with "F" or "Y" to have
  2070. *--                               the Friday treated as a holiday if
  2071. *--                               it would otherwise be the only working
  2072. *--                               day between the major holiday and the
  2073. *--                               weekend.
  2074. *--
  2075. *--                     Makehols.dbf must exist and must have its
  2076. *--                     holidays entered properly for this function to
  2077. *--                     succeed.  Since changes in the specification of
  2078. *--                     holidays applicable to an organization are rare,
  2079. *--                     no "front end" to facilitate changing the .dbf
  2080. *--                     is provided.
  2081. *--
  2082. *--                     Each HolsYYYY.dbf file created by this function
  2083. *--                     will have the following structure:
  2084. *--                             Holdate     D    8       Y
  2085. *--                             Holname     C   40       N
  2086. *--                     with one record for each nonworking day,
  2087. *--                     including each occurrence of the "W" types such
  2088. *--                     as Sundays.  Temporary files named Holsstru.dbf,
  2089. *--                     Holstemp.dbf and Holstemp.mdx are also created
  2090. *--                     and later deleted.
  2091. *--
  2092. *-- Written for.: dBASE IV, 1.5 or higher.
  2093. *-- Rev. History: 06/19/1993 - original version.
  2094. *--               08/03/1993 - Jay Parsons - retained active .dbf,
  2095. *--               conformed to Civildate()
  2096. *-- Calls.......: Time2Sec()           Function in TIME.PRG
  2097. *--               EasterDay()          Function in DATES.PRG
  2098. *--               Civildate()          Function in DATES.PRG
  2099. *--               HolXfer()            Function in DATES.PRG
  2100. *--               AddaHol()            Function in DATES.PRG
  2101. *-- Called by...: Any
  2102. *-- Usage.......: MakeHols(<nYear>)
  2103. *-- Example.....: MakeHols( 1993 )
  2104. *-- Returns.....: .T. if successful, or .F.
  2105. *-- Parameters..: nYear         -- the civil year of interest
  2106. *-------------------------------------------------------------------------------
  2107.  
  2108.    parameters nYear
  2109.    private nYr, cAlias, d1, d2, cName, cHoltype
  2110.    private cWeekly, lOk, nMo, cTemp, cFirst
  2111.  
  2112.    *  check for existence of main file
  2113.    if .not. file( "MakeHols.dbf" )
  2114.       RETURN .F.
  2115.    endif
  2116.  
  2117.    *  convert year to four digits
  2118.    m->nYr = m->nYear
  2119.    if m->nYr < 100
  2120.       m->nYr = m->nYr + 100 * int( year( date() ) / 100 )
  2121.    endif
  2122.  
  2123.    *  save current work area
  2124.    m->cAlias = Alias()
  2125.  
  2126.    * check date and time stamps.  Return if up to date or erase
  2127.    m->d1 = fdate( "Makehols.dbf" )
  2128.    m->cName = "Hols" + str( nYr, 4 )
  2129.    if file( m->cName + ".dbf" )
  2130.       m->d2 = fdate( m->cName + ".dbf" )
  2131.       if m->d2 > m->d1 .or. ;
  2132.           ( m->d2 = m->d1 .and. ;
  2133.           Time2Sec( ftime( m->cName + ".dbf" ) ) ;
  2134.           > Time2Sec( ftime( "Makehols.dbf" ) ) )
  2135.          RETURN .T.
  2136.       else
  2137.          delete file ( cName + ".dbf" )
  2138.       endif
  2139.    endif
  2140.    select select()
  2141.    if file( "Holstemp.dbf" )
  2142.       use Holstemp order Holdate
  2143.       zap
  2144.    else
  2145.       use Makehols
  2146.       copy to Holsstru structure extended
  2147.       use Holsstru
  2148.       zap
  2149.       append blank
  2150.       replace FIELD_NAME with "Holdate", ;
  2151.               FIELD_TYPE with "D", FIELD_LEN with 8, ;
  2152.               FIELD_DEC with 0, FIELD_IDX with "Y"
  2153.       append blank
  2154.       replace FIELD_NAME with "Holname", ;
  2155.               FIELD_TYPE with "C", FIELD_LEN with 40, ;
  2156.               FIELD_DEC with 0, FIELD_IDX with "N"
  2157.       create HolsTemp from HolsStru
  2158.       index on Holdate tag Holdate
  2159.       delete file HolsStru.dbf
  2160.    endif
  2161.  
  2162.    *--  now add the holidays to HolsTemp
  2163.    select select()
  2164.    use Makehols
  2165.    *--  MakeHols may be in no order, so start with weekly holidays
  2166.    m->d1 = ctod( "01/01/" + str( m->nYr, 4 ) )
  2167.    m->cWeekly = ""
  2168.    scan for upper( Holtype ) = "W"
  2169.       if upper( str( NumDow, 1 ) ) $ m->cWeekly
  2170.          loop
  2171.       else
  2172.          m->cWeekly = m->cWeekly + upper( str( NumDow, 1 ) )
  2173.       endif
  2174.       m->d2 = m->d1 + mod( NumDow + 7 - dow( m->d1 ), 7 )
  2175.       select Holstemp
  2176.       m->lOk = .T.
  2177.       do while m->lOk
  2178.          m->lOk = AddaHol( m->d2, m->nYr, cDow( m->d2 ) )
  2179.          m->d2 = m->d2 + 7
  2180.       enddo
  2181.       select Makehols
  2182.    endscan
  2183.  
  2184.    *--  then the other holidays
  2185.    scan for upper( Holtype ) # "W"
  2186.       m->cHoltype = upper( Holtype )
  2187.       m->cFirst = trim( Firstday ) ;
  2188.                   + iif( len( trim( Firstday ) ) = 5, "/","" )
  2189.       do case
  2190.          * fixed holidays - just transfer and add
  2191.          case m->cHoltype = "X"
  2192.             m->d1 = ctod( m->cFirst + str( m->nYr,4 ) )
  2193.             m->d2 = HolXfer( m->d1, m->cWeekly, upper( Xfer ) )
  2194.             m->lOk = AddaHol( m->d2, m->nYr, Holname )
  2195.          * floating holidays - use Holiday() or its
  2196.          * algorithm to find the date, transfer and add
  2197.          case m->cHoltype = "F"
  2198.             if val( m->cFirst ) = 0
  2199.                m->d1 = Holiday( m->nYr, m->cFirst )
  2200.             else
  2201.                m->d2 = m->d1 + 7 - NumDow
  2202.                m->d1 = m->d2 - dow( m->d2 ) + NumDow
  2203.             endif
  2204.             m->d2 = HolXfer( m->d1, str( NumDow, 1 ), upper( Xfer ) )
  2205.             m->lOk = AddaHol( m->d2, m->nYr, Holname )
  2206.          * Easter and dates referred to it - call
  2207.          * Easterday() to find the date, xfer and add
  2208.          case m->cHoltype = "E"
  2209.             m->d1 = EasterDay( m->nYr ) + val( m->cFirst )
  2210.             m->d2 = HolXfer( m->d1, m->cWeekly, upper( Xfer ) )
  2211.             m->lOk = AddaHol( m->d2, m->nYr, Holname )
  2212.          * Jewish holidays - convert to civil date,
  2213.          * transfer and add.  Some dates, although none
  2214.          * of the major holidays, may occur twice in a
  2215.          * civil year.
  2216.          case m->cHoltype = "J"
  2217.             m->nMo = val( m->cFirst )
  2218.             * first see if dates late in the Hebrew
  2219.             * year occurred early this year
  2220.             if m->nMo > 2 .or. m->nMo = 0
  2221.                m->d2 = Civildate( m->cFirst + str(m->nYr + 3760, 4 ) )
  2222.                if year( m->d2 ) # 0
  2223.                   m->lOk = AddaHol( m->d2, m->nYr, Holname )
  2224.                endif
  2225.             endif
  2226.             * then check to see if dates early in
  2227.             * the Hebrew year occurred late this yr
  2228.             if m->nMo > 0 .and. m->nMo < 5
  2229.                m->d2 = Civildate( m->cFirst + str(m->nYr + 3761, 4 ) )
  2230.                if year( m->d2 ) # 0
  2231.                   m->lOk = AddaHol( m->d2, m->nYr, Holname )
  2232.                endif
  2233.             endif
  2234.       endcase
  2235.  
  2236.       * add days for extended holidays as needed
  2237.       m->lOk = .F.
  2238.       if upper( Xtend ) $ "FY" .and. ;
  2239.           str( dow( m->d2 + 2 ), 1 ) $ m->cWeekly .and. ;
  2240.           .not. str( dow( m->d2 + 1 ), 1 ) $ m->cWeekly
  2241.          m->lOk = AddaHol( m->d2 + 1, m->nYr, trim( Holname ) + " ext" )
  2242.       endif
  2243.       if upper( Xtend ) $ "BY" .and. ;
  2244.           str( dow( m->d2 - 2 ), 1 ) $ m->cWeekly .and. ;
  2245.           .not. ( m->lOk .or. str( dow( m->d2 - 1 ), 1 ) ;
  2246.           $ m->cWeekly )
  2247.          m->lOk = AddaHol( m->d2 - 1, m->nYr, trim( Holname ) + " ext" )
  2248.       endif
  2249.    endscan
  2250.    select Holstemp
  2251.    copy to ( m->cName ) with production
  2252.    use
  2253.    erase Holstemp.dbf
  2254.    erase Holstemp.mdx
  2255.    select Makehols
  2256.    use
  2257.    if "" # m->cAlias
  2258.       select ( m->cAlias )
  2259.    endif
  2260.  
  2261. RETURN .T.
  2262. *-- EoF: MakeHols()
  2263.  
  2264. FUNCTION AddaHol
  2265. *-----------------------------------------------------------------------
  2266. *-- Programmer..: Jay Parsons (CIS: 72662,1302) 
  2267. *-- Date........: 06/26/1993
  2268. *-- Notes.......: Adds a date to Holstemp if in correct year and not
  2269. *--               already included.  Requires a file alias Holstemp in
  2270. *--               order Holdate in one work area and a file alias
  2271. *--               Makehols in another, ordinarily current, work area.
  2272. *--               If a holiday is already included, replaces the name.
  2273. *--               This so that if Makehols() has already included the
  2274. *--               Sundays, for example, but Easter or a Jewish holiday
  2275. *--               which is not transferred falls on Sunday, it will be
  2276. *--               included in Makehols.dbf under the (last) name rather
  2277. *--               than by the name of the day of the week.  This makes
  2278. *--               it easier to see in HolsYYYY that it has not been
  2279. *--               omitted by mistake.
  2280. *-- Written for.: dBASE IV, 1.1 or higher.
  2281. *-- Rev. History: 06/26/1993 - original function.
  2282. *-- Calls.......: None
  2283. *-- Called by...: Makehols(), usually.
  2284. *-- Usage.......: AddaHol(<dDate>,<nYr>,<cHolname>)
  2285. *-- Example.....: ? AddaHol( {12/25/93}, 1993, "Christmas" )
  2286. *-- Returns.....: .T. if added, or .F. if not added ( duplicate or wrong
  2287. *--               year)
  2288. *-- Parameters..: dDate     -- date to add
  2289. *--               nYr       -- year in which it must fall, four digits
  2290. *--               cHolname  -- name of the holiday
  2291. *-----------------------------------------------------------------------
  2292.  
  2293.    parameters dDate, nYr, cHolname
  2294.    private lReturn
  2295.  
  2296.    m->lReturn = .F.
  2297.    if year( m->dDate ) = m->nYr
  2298.       select Holstemp
  2299.       seek m->dDate
  2300.       if .not. found()
  2301.          append blank
  2302.          replace Holdate with m->dDate, ;
  2303.                  Holname with cHolname
  2304.          m->lReturn = .T.
  2305.       else
  2306.          replace Holname with cHolname
  2307.       endif
  2308.       select Makehols
  2309.    endif
  2310.  
  2311. RETURN m->lReturn
  2312. *-- EoF: AddaHol()
  2313.  
  2314. FUNCTION Holiday
  2315. *-----------------------------------------------------------------------
  2316. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  2317. *-- Date........: 08/03/1993
  2318. *-- Notes.......: Returns the date of a specified "floating" holiday
  2319. *--               (using table below) for current year.
  2320. *--               Name                 Code
  2321. *--               President's Day      P
  2322. *--               Daylight saving time D
  2323. *--               Memorial Day         M
  2324. *--               Labor Day            L
  2325. *--               Columbus Day         C
  2326. *--               resume Standard time S
  2327. *--               Election Day         E
  2328. *--               Thanksgiving         T
  2329. *--               Advent (1st Sunday)  A
  2330. *--                     To add additional days, specify the month and
  2331. *--               date the holiday may first possibly occur, MM/DD/, as
  2332. *--               cFirst, and the dow() on which it occurs as nDow.
  2333. *--               This will work only if the holiday occurs on a fixed
  2334. *--               day of the week in a fixed seven-day period.
  2335. *-- Written for.: dBASE IV, 1.1
  2336. *-- Rev. History: 11/01/1991 - original function.
  2337. *--               11/15/1991 - Ken Mayer - takes a code and year -- I
  2338. *--               basically simplified the use of the function.
  2339. *--               04/22/1992 - Jay Parsons - added 'D' and 'S' options
  2340. *--               (daylight saving time and return to standard)
  2341. *--``             08/03/1993 - Jay Parsons - removed change to parameter
  2342. *-- Calls.......: None
  2343. *-- Called by...: Any
  2344. *-- Usage.......: Holiday(<nYear>,"<cCode>")
  2345. *-- Example.....: ? Holiday(92,"P")   && date of President's day, 1992
  2346. *-- Returns.....: Date of specified holiday ...
  2347. *-- Parameters..: nYear = Year you need the holiday date for ...
  2348. *--               cCode = one of the codes above for specific holiday
  2349. *-----------------------------------------------------------------------
  2350.  
  2351.    parameters nYear,cCode
  2352.    private cC,cYear,cFirst,nDoW,dReturn,dBaseDate
  2353.    
  2354.    m->cC = upper( m->cCode )
  2355.    m->cYear = ltrim( str( m->nYear ) )
  2356.    do case
  2357.       case m->cC = "P"    && President's day (3rd Mon Feb)
  2358.          m->cFirst = "02/15/"
  2359.          m->nDoW   = 2
  2360.       case m->cC = "D"    && Daylight time U.S. (1st Sun Apr)
  2361.          m->cFirst = "04/01/"
  2362.          m->nDoW   = 1
  2363.       case m->cC = "M"    && Memorial day  (last Mon May)
  2364.          m->cFirst = "05/25/"
  2365.          m->nDoW   = 2
  2366.       case m->cC = "L"    && Labor day  (1st Mon Sep)
  2367.          m->cFirst = "09/01/"
  2368.          m->nDoW   = 2
  2369.       case m->cC = "C"    && Columbus Day  (2nd Mon Oct)
  2370.          m->cFirst = "10/08/"
  2371.          m->nDoW   = 2
  2372.       case m->cC = "S"    && Standard Time U.S. (last Sun Oct)
  2373.          m->cFirst = "10/25/"
  2374.          m->nDoW = 1
  2375.       case m->cC = "E"    && Election Day  (1st Tues Nov, but
  2376.                           && not Nov 1)
  2377.          m->cFirst = "11/02/"
  2378.          m->nDoW   = 3
  2379.       case m->cC = "T"    && Thanksgiving (4th Thurs Nov)
  2380.          m->cFirst = "11/22/"
  2381.          m->nDoW   = 5
  2382.       case m->cC = "A"    && 1st Sunday of Advent (Sunday
  2383.                           && closest to Nov 30)
  2384.          m->cFirst = "11/27/"
  2385.          m->nDoW   = 1
  2386.       otherwise
  2387.          RETURN {}   && return blank date for error
  2388.    endcase
  2389.    * start with first day the holiday may occur and use as the base
  2390.    * date that one of the possible dates that is a week ahead less
  2391.    * the dow() of the holiday--we later add the dow() back.
  2392.    m->dBasedate = ctod( m->cFirst + m->cYear) + 7 - m->nDow
  2393.    * Back up to the previous Saturday and add the dow().
  2394.    m->dReturn = m->dBaseDate - dow( m->dBaseDate ) + m->nDoW
  2395.    
  2396. RETURN m->dReturn
  2397. *-- EoF: Holiday()
  2398.  
  2399. FUNCTION IsLeap
  2400. *-----------------------------------------------------------------------
  2401. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  2402. *-- Date........: 08/03/1993
  2403. *-- Notes.......: Is the year given a Leap Year? Year given must be
  2404. *--               after 1500 C.E.
  2405. *-- Written for.: dBASE IV, 1.1
  2406. *-- Rev. History: 11/08/1991 - Jay Parsons - original function
  2407. *--               01/13/1992 - Jay Parsons - updated to handle two-digit
  2408. *--               OR four-digit year.
  2409. *--               08/03/1993 - Jay Parsons - removed change to parameter
  2410. *-- Calls.......: None
  2411. *-- Called by...: Any
  2412. *-- Usage.......: IsLeap(<nYear>)
  2413. *-- Example.....: IsLeap(91)
  2414. *-- Returns.....: Logical (.t./.f.) 
  2415. *-- Parameters..: nYear  = Numeric form of year -- last two digits
  2416. *--                        (i.e., 91), or all four digits (i.e., 1991)
  2417. *-----------------------------------------------------------------------
  2418.    
  2419.    parameter nYear
  2420.    private nYr, lReturn
  2421.    
  2422.    *-- deal with two digit year ...
  2423.    m->nYr = m->nYear
  2424.    if m->nYr < 100
  2425.       m->nYr = m->nYr + 100 * int( year( date() ) / 100 )
  2426.    endif
  2427.    
  2428.    m->lReturn = mod( iif( mod( m->nYr, 100 ) = 0, ;
  2429.                      m->nYr / 100, m->nYr ), 4 ) = 0
  2430.    
  2431. RETURN m->lReturn
  2432. *-- EoF: IsLeap()
  2433.  
  2434. FUNCTION Num2Dat
  2435. *-----------------------------------------------------------------------
  2436. *-- Programmer..: Raymond S. Leventhal (CIS: 71544,2140)
  2437. *-- Date........: 06/04/1992
  2438. *-- Notes.......: Changes Date format from *numeric* yymmdd to dBASE 
  2439. *--               date format. The author uses an AS/400 and downloads 
  2440. *--               data, the YYMMDD format is the date format used by the
  2441. *--               AS/400.
  2442. *-- Rev. History: 06/04/1992 -- Original version
  2443. *-- Calls.......: None
  2444. *-- Called by...: Any
  2445. *-- Usage.......: Num2Dat(<nYyMmDd>)
  2446. *-- Example.....: ?Num2Dat(930820)
  2447. *-- Returns.....: Date format value of nYyMmDd (i.e. 08/20/93)
  2448. *-- Parameters..: nYyMmDd = Numeric value YyMmDd to be converted to 
  2449. *--                         date
  2450. *-----------------------------------------------------------------------
  2451.  
  2452.    parameters nYyMmDd
  2453.  
  2454. RETURN ctod(substr(ltrim(str(m->nYyMmDd)),3,2)+"/"+;
  2455.        right(ltrim(str(m->nYyMmDd)),2)+"/"+;
  2456.        left(ltrim(str(m->nYyMmDd)),2))
  2457. *-- EOF: Num2Dat()
  2458.  
  2459. FUNCTION Epoch
  2460. *-----------------------------------------------------------------------
  2461. *-- Programmer..: Angus Scott-Fleming (75500,3223)
  2462. *-- Date........: 10/15/1993
  2463. *-- Notes.......: Adjusts a date to within 100 years after a given
  2464. *--               Epoch. Set a PUBLIC date memvar called "dEpoch"
  2465. *--               and set it to the year beginning your Epoch, or use
  2466. *--               method 2 to set the Epoch to the century beginning
  2467. *--               with <year>. There are four ways to use Epoch:
  2468. *--               1. Epoch(<date>[,.T.])    returns .t., fixes date,
  2469. *--                                         leaves Epoch unchanged
  2470. *--               2. Epoch(<date>,<year>)   returns fixed date, sets
  2471. *--                                         Epoch to <year>
  2472. *--               3. Epoch(<date>,<date>)   returns fixed date, leaves
  2473. *--                                         Epoch unchanged.
  2474. *--               4. Epoch(<date>,.t.,<yr>) Returns .t., fixes date,
  2475. *--                                         sets Epoch to <year>
  2476. *-- Written for.: dBASE IV, 1.1
  2477. *-- Rev. History: 10/15/1993 -- Original
  2478. *-- Calls.......: AddYears             Function in DATES.PRG
  2479. *-- Called by...: Any
  2480. *-- Usage.......: Epoch(<date>,<xReturn>[,<nEpoch>])
  2481. *-- Example.....: @.. GET dDate valid required Epoch(dDate)
  2482. *--               dDate = Epoch(dDate,1900)
  2483. *-- Returns.....: logical
  2484. *-- Parameters..: dDate    = date being adjusted
  2485. *--               xReturn  = optional to control type of return & epoch
  2486. *--                          if logical, return .T.
  2487. *--                          if numeric, use as base year for dEpoch
  2488. *--                          if date, use as temporary base for Epoch
  2489. *--               nEpoch   = optional if logical return is needed to set
  2490. *--                          beginning year for Epoch.
  2491. *-----------------------------------------------------------------------
  2492.  
  2493.    parameters dDate, xReturn, nEpoch
  2494.    private dTemp, dDiff
  2495.  
  2496.    if type("dEpoch") = "U"
  2497.       public dEpoch
  2498.       store {01/01/1950} to dEpoch  && enter your default choice here
  2499.    endif
  2500.  
  2501.    do case
  2502.       case pcount() = 3 .and. type("nEpoch") = "N"
  2503.          store ctod("01/01/"+str(m->nEpoch,4,0)) to dEpoch
  2504.       case type("xReturn") = "N"
  2505.          * set both temporary Epoch AND permanent Epoch
  2506.          store ctod("01/01/"+str(m->xReturn,4,0)) to dEpoch
  2507.       otherwise
  2508.          * leave existing dEpoch alone
  2509.    endcase
  2510.  
  2511.    dTemp = iif(type("xReturn") = "D",m->xReturn,m->dEpoch)
  2512.    dDiff = m->dDate - m->dTemp
  2513.    do while (m->dDiff < 0 .or. m->dDiff > 36525)
  2514.       do case
  2515.          case m->dDate < m->dTemp
  2516.             dDate = AddYears(m->dDate,100)
  2517.          case m->dDate => AddYears(m->dTemp,100)
  2518.             dDate = AddYears(m->dDate,-100)
  2519.       endcase
  2520.       dDiff = m->dDate - m->dTemp
  2521.    enddo
  2522.  
  2523. RETURN iif(type("xReturn")="L",.t.,m->dDate)
  2524. *-- EoF: Epoch()
  2525.  
  2526. *=======================================================================
  2527. *-- The following functions have been included for use with routines
  2528. *-- contained in DATES.PRG, but are from other files in the library.
  2529. *=======================================================================
  2530.  
  2531. FUNCTION Time2Sec
  2532. *-----------------------------------------------------------------------
  2533. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  2534. *-- Date........: 03/01/1992
  2535. *-- Notes.......: Convert HH:MM:SS or HH:MM:SS.SS string to seconds.
  2536. *-- Written for.: dBASE IV
  2537. *-- Rev. History: 03/01/1992 -- Original
  2538. *-- Calls.......: None
  2539. *-- Called by...: Any
  2540. *-- Usage.......: Time2Sec("<cTime>")
  2541. *-- Example.....: ?Time2Sec("01:24:15")
  2542. *-- Returns.....: Numeric
  2543. *-- Parameters..: cTime = Time string in format HH:MM:SS or HH:MM:SS.SS
  2544. *-----------------------------------------------------------------------
  2545.    
  2546.    parameters cTime
  2547.    private cTemp, nSecs
  2548.  
  2549.    m->cTemp = cTime
  2550.    m->nSecs = 3600 * val( m->cTemp )
  2551.    m->cTemp = substr( m->cTemp, at( ":", m->cTemp ) + 1 )
  2552.    m->nSecs = m->nSecs + 60 * val( m->cTemp )
  2553.    
  2554. RETURN m->nSecs + val( substr( m->cTemp, at( ":", m->cTemp ) + 1 ) )
  2555. *-- EoF: Time2Sec()
  2556.  
  2557. FUNCTION Strip
  2558. *----------------------------------------------------------------------
  2559. *-- Programmer..: Kenneth Chan [ZAK] (CIS: 72662,1305)
  2560. *-- Date........: 01/05/1993
  2561. *-- Notes.......: Strips out specified character(s) from a string
  2562. *-- Written for.: dBASE IV, 1.5
  2563. *-- Rev. History: 01/05/1993 -- Original Release
  2564. *-- Calls.......: None
  2565. *-- Called by...: Any
  2566. *-- Usage.......: Strip(<cVar>,<cArg>)
  2567. *-- Example.....: ?strip(dtoc(date(),"/")
  2568. *-- Returns.....: Character
  2569. *-- Parameters..: cVar = variable/field to remove character(s) from
  2570. *--               cArg = item to remove from cVar
  2571. *----------------------------------------------------------------------
  2572.  
  2573.   parameter cVar, cArg
  2574.  
  2575.   do while m->cArg $ m->cVar
  2576.     cVar = stuff( m->cVar, at( m->cArg, m->cVar ), 1, "" )
  2577.   enddo
  2578.  
  2579. RETURN m->cVar
  2580. *-- EoF: Strip()
  2581.  
  2582. *-----------------------------------------------------------------------
  2583. *-- EoP: DATES.PRG
  2584. *-----------------------------------------------------------------------
  2585.  
  2586.  
  2587.  
  2588.  
  2589.  
  2590.  
  2591.  
  2592.  
  2593.  
  2594.  
  2595.  
  2596.